[Git][ghc/ghc][wip/sgraf-dmdanal-stuff] 2 commits: DmdAnal: Keep alive RULE vars in LetUp (#18971)

Sebastian Graf gitlab at gitlab.haskell.org
Fri Dec 18 09:55:20 UTC 2020



Sebastian Graf pushed to branch wip/sgraf-dmdanal-stuff at Glasgow Haskell Compiler / GHC


Commits:
c6e5bbaf by Sebastian Graf at 2020-12-18T10:55:09+01:00
DmdAnal: Keep alive RULE vars in LetUp (#18971)

I also took the liberty to refactor the logic around `ruleFVs`.

- - - - -
aeaa9126 by Sebastian Graf at 2020-12-18T10:55:09+01:00
WorkWrap: Unbox constructors with existentials (#18982)

Consider

```hs
data Ex where
  Ex :: e -> Int -> Ex

f :: Ex -> Int
f (Ex e n) = e `seq` n + 1
```

Worker/wrapper should build the following worker for `f`:

```hs
$wf :: forall e. e -> Int# -> Int#
$wf e n = e `seq` n +# 1#
```

But previously it didn't, because `Ex` binds an existential.
This patch lifts that condition. That entailed having to instantiate
existential binders in `GHC.Core.Opt.WorkWrap.Utils.mkWWstr` via
`GHC.Core.Utils.dataConRepFSInstPat`, requiring a bit of a refactoring
around what is now `DataConPatContext`.

CPR W/W still won't unbox DataCons with existentials.
See `Note [Which types are unboxed?]` for details.

I also refactored the various `tyCon*DataCon(s)_maybe` functions in
`GHC.Core.TyCon`, deleting some of them which are no longer needed
(`isDataProductType_maybe` and `isDataSumType_maybe`).
I cleaned up a couple of call sites, some of which weren't very explicit
about whether they cared for existentials or not.

The test output of `T18013` changed, because we now unbox the `Rule`
data type. Its constructor carries existential state and will be
w/w'd now. In the particular example, the worker functions inlines right
back into the wrapper, which then unnecessarily has a (quite big) stable
unfolding. I think this kind of fallout is inevitable;
see also Note [Don't w/w inline small non-loop-breaker things].

There's a new regression test case `T18982`.
Fixes #18982.

- - - - -


16 changed files:

- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Types/Demand.hs
- testsuite/tests/simplCore/should_compile/T18013.stderr
- + testsuite/tests/stranal/should_compile/T18982.hs
- + testsuite/tests/stranal/should_compile/T18982.stderr
- testsuite/tests/stranal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -1564,15 +1564,13 @@ promoteDataCon (MkData { dcPromoted = tc }) = tc
 -- | Extract the type constructor, type argument, data constructor and it's
 -- /representation/ argument types from a type if it is a product type.
 --
--- Precisely, we return @Just@ for any type that is all of:
+-- Precisely, we return @Just@ for any data type that is all of:
 --
 --  * Concrete (i.e. constructors visible)
---
 --  * Single-constructor
+--  * ... which has no existentials
 --
---  * Not existentially quantified
---
--- Whether the type is a @data@ type or a @newtype@
+-- Whether the type is a @data@ type or a @newtype at .
 splitDataProductType_maybe
         :: Type                         -- ^ A product type, perhaps
         -> Maybe (TyCon,                -- The type constructor
@@ -1580,13 +1578,14 @@ splitDataProductType_maybe
                   DataCon,              -- The data constructor
                   [Scaled Type])        -- Its /representation/ arg types
 
-        -- Rejecting existentials is conservative.  Maybe some things
-        -- could be made to work with them, but I'm not going to sweat
-        -- it through till someone finds it's important.
+        -- Rejecting existentials means we don't have to worry about
+        -- freshening and substituting type variables
+        -- (See "GHC.Type.Id.Make.dataConArgUnpack")
 
 splitDataProductType_maybe ty
   | Just (tycon, ty_args) <- splitTyConApp_maybe ty
-  , Just con <- isDataProductTyCon_maybe tycon
+  , Just con <- tyConSingleDataCon_maybe tycon
+  , null (dataConExTyCoVars con) -- no existentials! See above
   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
   | otherwise
   = Nothing


=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -28,12 +28,13 @@ module GHC.Core.FVs (
         varTypeTyCoFVs,
         idUnfoldingVars, idFreeVars, dIdFreeVars,
         bndrRuleAndUnfoldingVarsDSet,
+        bndrRuleAndUnfoldingIds,
         idFVs,
-        idRuleVars, idRuleRhsVars, stableUnfoldingVars,
+        idRuleVars, stableUnfoldingVars,
         ruleFreeVars, rulesFreeVars,
         rulesFreeVarsDSet, mkRuleInfo,
         ruleLhsFreeIds, ruleLhsFreeIdsList,
-        ruleRhsFreeVars, ruleRhsFreeIds,
+        ruleRhsFreeVars, rulesRhsFreeIds,
 
         expr_fvs,
 
@@ -62,8 +63,6 @@ import GHC.Core
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Name.Set
-import GHC.Types.Unique.Set
-import GHC.Types.Unique (Uniquable (..))
 import GHC.Types.Name
 import GHC.Types.Var.Set
 import GHC.Types.Var
@@ -76,7 +75,6 @@ import GHC.Core.FamInstEnv
 import GHC.Builtin.Types( unrestrictedFunTyConName )
 import GHC.Builtin.Types.Prim( funTyConName )
 import GHC.Data.Maybe( orElse )
-import GHC.Types.Basic( Activation )
 
 import GHC.Utils.FV as FV
 import GHC.Utils.Misc
@@ -450,87 +448,71 @@ orph_names_of_fun_ty_con _ = emptyNameSet
 ************************************************************************
 -}
 
+data RuleFVsFrom
+  = LhsOnly
+  | RhsOnly
+  | BothSides
+
+-- | Those locally-defined variables free in the left and/or right hand sides
+-- of the rule, depending on the first argument. Returns an 'FV' computation.
+ruleFVs :: RuleFVsFrom -> CoreRule -> FV
+ruleFVs !_   (BuiltinRule {}) = emptyFV
+ruleFVs from (Rule { ru_fn = _do_not_include
+                     -- See Note [Rule free var hack]
+                   , ru_bndrs = bndrs
+                   , ru_rhs = rhs, ru_args = args })
+  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)
+  where
+    exprs = case from of
+      LhsOnly   -> args
+      RhsOnly   -> [rhs]
+      BothSides -> rhs:args
+
+-- | Those locally-defined variables free in the left and/or right hand sides
+-- from several rules, depending on the first argument.
+-- Returns an 'FV' computation.
+rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV
+rulesFVs from = mapUnionFV (ruleFVs from)
+
 -- | Those variables free in the right hand side of a rule returned as a
 -- non-deterministic set
 ruleRhsFreeVars :: CoreRule -> VarSet
-ruleRhsFreeVars (BuiltinRule {}) = noFVs
-ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
-  = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
-      -- See Note [Rule free var hack]
+ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly
 
--- | Those variables free in the both the left right hand sides of a rule
+-- | Those locally-defined free 'Id's in the right hand side of several rules
 -- returned as a non-deterministic set
-ruleFreeVars :: CoreRule -> VarSet
-ruleFreeVars = fvVarSet . ruleFVs
+rulesRhsFreeIds :: [CoreRule] -> VarSet
+rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly
 
--- | Those variables free in the both the left right hand sides of a rule
--- returned as FV computation
-ruleFVs :: CoreRule -> FV
-ruleFVs (BuiltinRule {}) = emptyFV
-ruleFVs (Rule { ru_fn = _do_not_include
-                  -- See Note [Rule free var hack]
-              , ru_bndrs = bndrs
-              , ru_rhs = rhs, ru_args = args })
-  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))
+ruleLhsFreeIds :: CoreRule -> VarSet
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns them as a non-deterministic set
+ruleLhsFreeIds = fvVarSet . filterFV isLocalId . ruleFVs LhsOnly
 
--- | Those variables free in the both the left right hand sides of rules
--- returned as FV computation
-rulesFVs :: [CoreRule] -> FV
-rulesFVs = mapUnionFV ruleFVs
+ruleLhsFreeIdsList :: CoreRule -> [Var]
+-- ^ This finds all locally-defined free Ids on the left hand side of a rule
+-- and returns them as a deterministically ordered list
+ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly
+
+-- | Those variables free in the both the left right hand sides of a rule
+-- returned as a non-deterministic set
+ruleFreeVars :: CoreRule -> VarSet
+ruleFreeVars = fvVarSet . ruleFVs BothSides
 
 -- | Those variables free in the both the left right hand sides of rules
 -- returned as a deterministic set
 rulesFreeVarsDSet :: [CoreRule] -> DVarSet
-rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules
+rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules
+
+-- | Those variables free in both the left right hand sides of several rules
+rulesFreeVars :: [CoreRule] -> VarSet
+rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules
 
 -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
 -- for putting into an 'IdInfo'
 mkRuleInfo :: [CoreRule] -> RuleInfo
 mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
 
-idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
--- Just the variables free on the *rhs* of a rule
-idRuleRhsVars is_active id
-  = mapUnionVarSet get_fvs (idCoreRules id)
-  where
-    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
-                  , ru_rhs = rhs, ru_act = act })
-      | is_active act
-            -- See Note [Finding rule RHS free vars] in "GHC.Core.Opt.OccurAnal"
-      = delOneFromUniqSet_Directly fvs (getUnique fn)
-            -- Note [Rule free var hack]
-      where
-        fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
-    get_fvs _ = noFVs
-
--- | Those variables free in the right hand side of several rules
-rulesFreeVars :: [CoreRule] -> VarSet
-rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules
-
-ruleLhsFreeIds :: CoreRule -> VarSet
--- ^ This finds all locally-defined free Ids on the left hand side of a rule
--- and returns them as a non-deterministic set
-ruleLhsFreeIds = fvVarSet . ruleLhsFVIds
-
-ruleLhsFreeIdsList :: CoreRule -> [Var]
--- ^ This finds all locally-defined free Ids on the left hand side of a rule
--- and returns them as a deterministically ordered list
-ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds
-
-ruleLhsFVIds :: CoreRule -> FV
--- ^ This finds all locally-defined free Ids on the left hand side of a rule
--- and returns an FV computation
-ruleLhsFVIds (BuiltinRule {}) = emptyFV
-ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
-  = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)
-
-ruleRhsFreeIds :: CoreRule -> VarSet
--- ^ This finds all locally-defined free Ids on the right hand side of a rule
--- and returns them as a non-deterministic set
-ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
-  = fvVarSet $ filterFV isLocalId $ addBndrs bndrs $ expr_fvs rhs
-
 {-
 Note [Rule free var hack]  (Not a hack any more)
 ~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -586,9 +568,6 @@ freeVarsOf (fvs, _) = fvs
 freeVarsOfAnn :: FVAnn -> DIdSet
 freeVarsOfAnn fvs = fvs
 
-noFVs :: VarSet
-noFVs = emptyVarSet
-
 aFreeVar :: Var -> DVarSet
 aFreeVar = unitDVarSet
 
@@ -660,6 +639,9 @@ idFVs id = ASSERT( isId id)
 bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
 bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id
 
+bndrRuleAndUnfoldingIds :: Id -> IdSet
+bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id
+
 bndrRuleAndUnfoldingFVs :: Id -> FV
 bndrRuleAndUnfoldingFVs id
   | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id


=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -425,7 +425,7 @@ nonVirgin env = env { ae_virgin = False }
 extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv
 extendSigEnvForDemand env id dmd
   | isId id
-  , Just (_, DataConAppContext { dcac_dc = dc })
+  , Just (_, DataConPatContext { dcpc_dc = dc })
       <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd
   = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))
   | otherwise
@@ -446,14 +446,12 @@ extendEnvForDataAlt env scrut case_bndr dc bndrs
 
     ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc
 
-    tycon          = dataConTyCon dc
-    is_product     = isJust (isDataProductTyCon_maybe tycon)
-    is_sum         = isJust (isDataSumTyCon_maybe tycon)
+    is_algebraic   = isJust (tyConAlgDataCons_maybe (dataConTyCon dc))
+    no_exs         = null (dataConExTyCoVars dc)
     case_bndr_ty
-      | is_product || is_sum = conCprType  (dataConTag dc)
-      -- Any of the constructors had existentials. This is a little too
-      -- conservative (after all, we only care about the particular data con),
-      -- but there is no easy way to write is_sum and this won't happen much.
+      | is_algebraic, no_exs = conCprType (dataConTag dc)
+      -- The tycon wasn't algebraic or the datacon had existentials.
+      -- See Note [Which types are unboxed?] for why no existentials.
       | otherwise            = topCprType
 
     -- We could have much deeper CPR info here with Nested CPR, which could


=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -34,7 +34,7 @@ import GHC.Types.Id
 import GHC.Core.Utils
 import GHC.Core.TyCon
 import GHC.Core.Type
-import GHC.Core.FVs      ( exprFreeIds, ruleRhsFreeIds )
+import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
 import GHC.Core.Coercion ( Coercion, coVarsOfCo )
 import GHC.Core.FamInstEnv
 import GHC.Core.Opt.Arity ( typeArity )
@@ -96,7 +96,7 @@ dmdAnalProgram opts fam_envs rules binds
       = dmd_ty
 
     rule_fvs :: IdSet
-    rule_fvs = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
+    rule_fvs = rulesRhsFreeIds rules
 
 -- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
 -- that satisfy this function.
@@ -265,7 +265,10 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body
     (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
     id'                = setBindIdDemandInfo top_lvl id id_dmd
     (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
-    final_ty           = body_ty' `plusDmdType` rhs_ty
+
+    -- See Note [Absence analysis for stable unfoldings and RULES]
+    rule_fvs           = bndrRuleAndUnfoldingIds id
+    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs
 
 -- | Let bindings can be processed in two ways:
 -- Down (RHS before body) or Up (body before RHS).
@@ -423,8 +426,8 @@ dmdAnal' env dmd (Lam var body)
 
 dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)])
   -- Only one alternative.
-  -- If it's a DataAlt, it should be a product constructor.
-  | is_non_sum_alt alt
+  -- If it's a DataAlt, it should be the only constructor of the type.
+  | is_single_data_alt alt
   = let
         (rhs_ty, rhs')           = dmdAnal env dmd rhs
         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
@@ -463,8 +466,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)])
 --                                   , text "res_ty" <+> ppr res_ty ]) $
     (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')])
     where
-      is_non_sum_alt (DataAlt dc) = isJust $ isDataProductTyCon_maybe $ dataConTyCon dc
-      is_non_sum_alt _            = True
+      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc
+      is_single_data_alt _            = True
 
 dmdAnal' env dmd (Case scrut case_bndr ty alts)
   = let      -- Case expression with multiple alternatives
@@ -524,10 +527,11 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool
 forcesRealWorld fam_envs ty
   | ty `eqType` realWorldStatePrimTy
   = True
-  | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
+  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }
       <- deepSplitProductType_maybe fam_envs ty
   , isUnboxedTupleDataCon dc
-  = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys
+  , let field_tys = dataConInstArgTys dc tc_args
+  = any (eqType realWorldStatePrimTy . scaledThing) field_tys
   | otherwise
   = False
 
@@ -809,21 +813,12 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
                 Recursive    -> reuseEnv rhs_fv
                 NonRecursive -> rhs_fv
 
-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs
-    -- Find the RHS free vars of the unfoldings and RULES
     -- See Note [Absence analysis for stable unfoldings and RULES]
-    extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $
-                idCoreRules id
+    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
 
     -- See Note [Lazy and unleashable free variables]
     (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
 
-    unf = realIdUnfolding id
-    unf_fvs | isStableUnfolding unf
-            , Just unf_body <- maybeUnfoldingTemplate unf
-            = exprFreeIds unf_body
-            | otherwise = emptyVarSet
-
 -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
 -- whether we should process the binding up (body before rhs) or down (rhs
 -- before body).


=====================================
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
-   , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox
+   , DataConPatContext(..), deepSplitProductType_maybe, wantToUnbox
    , findTypeShape
    , isWorkerSmallEnough
    )
@@ -19,7 +19,8 @@ where
 import GHC.Prelude
 
 import GHC.Core
-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )
+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase
+                        , dataConRepFSInstPat )
 import GHC.Types.Id
 import GHC.Types.Id.Info ( JoinArity )
 import GHC.Core.DataCon
@@ -43,9 +44,11 @@ import GHC.Core.TyCon
 import GHC.Core.TyCon.RecWalk
 import GHC.Types.Unique.Supply
 import GHC.Types.Unique
+import GHC.Types.Name ( getOccFS )
 import GHC.Data.Maybe
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
+import GHC.Utils.Panic
 import GHC.Driver.Session
 import GHC.Driver.Ppr
 import GHC.Data.FastString
@@ -606,53 +609,53 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
     arg_ty = idType arg
     dmd    = idDemandInfo arg
 
-wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)
+wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext)
+-- See Note [Which types are unboxed?]
 wantToUnbox fam_envs has_inlineable_prag ty dmd =
   case deepSplitProductType_maybe fam_envs ty of
-    Just dcac at DataConAppContext{ dcac_arg_tys = con_arg_tys }
+    Just dcpc at DataConPatContext{ dcpc_dc = dc }
       | isStrUsedDmd dmd
+      , let arity = dataConRepArity dc
       -- See Note [Unpacking arguments with product and polymorphic demands]
-      , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)
+      , Just cs <- split_prod_dmd_arity dmd arity
       -- See Note [Do not unpack class dictionaries]
       , not (has_inlineable_prag && isClassPred ty)
       -- See Note [mkWWstr and unsafeCoerce]
-      , cs `equalLength` con_arg_tys
-      -> Just (cs, dcac)
+      , cs `lengthIs` arity
+      -> Just (cs, dcpc)
     _ -> Nothing
   where
-    split_prod_dmd_arity dmd arty
+    split_prod_dmd_arity dmd arity
       -- For seqDmd, it should behave like <S(AAAA)>, for some
       -- suitable arity
-      | isSeqDmd dmd        = Just (replicate arty absDmd)
+      | isSeqDmd dmd        = Just (replicate arity absDmd)
       | _ :* Prod ds <- dmd = Just ds
       | otherwise           = Nothing
 
 unbox_one :: DynFlags -> FamInstEnvs -> Var
           -> [Demand]
-          -> DataConAppContext
+          -> DataConPatContext
           -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 unbox_one dflags fam_envs arg cs
-          DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys
-                            , dcac_arg_tys = inst_con_arg_tys
-                            , dcac_co = co }
-  = do { (uniq1:uniqs) <- getUniquesM
-        ; let   scale = scaleScaled (idMult arg)
-                scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys
-                -- See Note [Add demands for strict constructors]
-                cs'       = addDataConStrictness data_con cs
-                unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs'
-                unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) uniq1
-                                         data_con unpk_args
-                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 data_con inst_tys unpk_args `mkCast` mkSymCo co
-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args
-         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
-                           -- Don't pass the arg, rebox instead
-  where
-    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
+          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
 
 ----------------------
 nop_fn :: CoreExpr -> CoreExpr
@@ -932,73 +935,72 @@ off the unpacking in mkWWstr_one (see the isClassPred test).
 Historical note: #14955 describes how I got this fix wrong the first time.
 -}
 
--- | Context for a 'DataCon' application with a hole for every field, including
--- surrounding coercions.
+-- | Context for a 'DataCon' pattern wrapped in a cast, where we know the type
+-- arguments of the 'TyCon' but not any of the arguments to the 'DataCon' (type
+-- or term).
+--
 -- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'.
 --
 -- Example:
 --
--- > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int)
+-- > DataConPatContext Right [Int, Bool] (co :: Right Int Bool ~ NT Char)
 --
 -- represents
 --
--- > Just @Int (_1 :: Int) |> co :: First Int
+-- > (Right ... :: Either Int Bool) |> co :: NT Char
 --
--- where _1 is a hole for the first argument. The number of arguments is
--- determined by the length of @arg_tys at .
-data DataConAppContext
-  = DataConAppContext
-  { dcac_dc      :: !DataCon
-  , dcac_tys     :: ![Type]
-  , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)]
-  , dcac_co      :: !Coercion
+data DataConPatContext
+  = DataConPatContext
+  { dcpc_dc        :: !DataCon
+  , dcpc_tc_args   :: ![Type]
+  , dcpc_co        :: !Coercion
   }
 
-deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext
--- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
--- then  dc @ tys (args::arg_tys) :: rep_ty
---       co :: ty ~ rep_ty
--- Why do we return the strictness of the data-con arguments?
--- Answer: see Note [Record evaluated-ness in worker/wrapper]
+-- | If @deepSplitProductType_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?].
+deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext
 deepSplitProductType_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 <- isDataProductTyCon_maybe tc
-  , let arg_tys = dataConInstArgTys con tc_args
-        strict_marks = dataConRepStrictness con
-  = Just DataConAppContext { dcac_dc = con
-                           , dcac_tys = tc_args
-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks
-                           , dcac_co = co }
+  , Just con <- tyConSingleAlgDataCon_maybe tc
+  = Just DataConPatContext { dcpc_dc      = con
+                           , dcpc_tc_args = tc_args
+                           , dcpc_co      = co }
 deepSplitProductType_maybe _ _ = Nothing
 
-deepSplitCprType_maybe
-  :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext
--- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
--- then  dc @ tys (args::arg_tys) :: rep_ty
---       co :: ty ~ rep_ty
--- Why do we return the strictness of the data-con arguments?
--- Answer: see Note [Record evaluated-ness in worker/wrapper]
+-- | If @deepSplitCprType_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 at th data constructor of @tc at .
+--
+-- See Note [Which types are unboxed?].
+deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext
 deepSplitCprType_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
+  , 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-bool file (#8743)
+                                 -- type constructor via a .hs-boot file (#8743)
   , let con = cons `getNth` (con_tag - fIRST_TAG)
-        arg_tys = dataConInstArgTys con tc_args
-        strict_marks = dataConRepStrictness con
-  , all isLinear arg_tys
+  , 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 DataConAppContext { dcac_dc = con
-                           , dcac_tys = tc_args
-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks
-                           , dcac_co = co }
+  = Just DataConPatContext { dcpc_dc = con
+                           , dcpc_tc_args = tc_args
+                           , dcpc_co = co }
 deepSplitCprType_maybe _ _ _ = Nothing
 
 isLinear :: Scaled a -> Bool
@@ -1035,13 +1037,16 @@ findTypeShape fam_envs ty
        | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
        = go rec_tc rhs
 
-       | Just con <- isDataProductTyCon_maybe tc
+       | Just con <- tyConSingleAlgDataCon_maybe tc
        , Just rec_tc <- if isTupleTyCon tc
                         then Just rec_tc
                         else checkRecTc rec_tc tc
          -- We treat tuples specially because they can't cause loops.
          -- Maybe we should do so in checkRecTc.
-       = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args))
+         -- The use of 'dubiousDataConInstArgTys' is OK, since this
+         -- function performs no substitution at all, hence the uniques
+         -- don't matter.
+       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))
 
        | Just (ty', _) <- instNewTyCon_maybe tc tc_args
        , Just rec_tc <- checkRecTc rec_tc tc
@@ -1050,7 +1055,54 @@ findTypeShape fam_envs ty
        | otherwise
        = TsUnk
 
-{-
+-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
+-- the 'DataCon' may not have existentials. The lack of cloning the existentials
+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";
+-- only use it where type variables aren't substituted for!
+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
+dubiousDataConInstArgTys dc tc_args = arg_tys
+  where
+    univ_tvs = dataConUnivTyVars dc
+    ex_tvs   = dataConExTyCoVars dc
+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs
+    arg_tys  = 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)
+       * 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 'deepSplitProductType_maybe' and
+'deepSplitCprType_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}
@@ -1083,35 +1135,36 @@ 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 dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty
-                    -> mkWWcpr_help dcac
+       Just con_tag | Just dcpc <- deepSplitCprType_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 :: DataConAppContext
+mkWWcpr_help :: DataConPatContext
              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
 
-mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys
-                                , dcac_arg_tys = arg_tys, dcac_co = co })
-  | [arg1@(arg_ty1, _)] <- arg_tys
-  , isUnliftedType (scaledThing arg_ty1)
-  , isLinear arg_ty1
+mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
+                                , dcpc_co = co })
+  | [arg_ty]   <- arg_tys
+  , [str_mark] <- str_marks
+  , isUnliftedType (scaledThing arg_ty)
+  , isLinear arg_ty
         -- Special case when there is a single result of unlifted, linear, type
         --
         -- Wrapper:     case (..call worker..) of x -> C x
         -- Worker:      case (   ..body..    ) of C x -> x
   = do { (work_uniq : arg_uniq : _) <- getUniquesM
-       ; let arg       = mk_ww_local arg_uniq arg1
-             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
+       ; let arg_id    = mk_ww_local arg_uniq str_mark arg_ty
+             con_app   = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co
 
        ; return ( True
-                , \ wkr_call -> mkDefaultCase wkr_call arg con_app
-                , \ body     -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg)
+                , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app
+                , \ body     -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)
                                 -- varToCoreExpr important here: arg can be a coercion
                                 -- Lacking this caused #10658
-                , scaledThing arg_ty1 ) }
+                , scaledThing arg_ty ) }
 
   | otherwise   -- The general case
         -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
@@ -1123,19 +1176,26 @@ mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys
         -- parametrised by the multiplicity of its fields. Specifically, in this
         -- instance, the multiplicity of the fields of (#,#) is chosen to be the
         -- same as those of C.
-  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
-       ; let wrap_wild   = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict)
-             args        = zipWith mk_ww_local uniqs arg_tys
-             ubx_tup_ty  = exprType ubx_tup_app
-             ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args)
-             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
-             tup_con     = tupleDataCon Unboxed (length arg_tys)
+  = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM
+       ; let case_mult       = One -- see above
+             (_exs, arg_ids) =
+               dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args
+             wrap_wild       = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)
+             ubx_tup_ty      = exprType ubx_tup_app
+             ubx_tup_app     = mkCoreUbxTup (map scaledThing arg_tys) (map varToCoreExpr arg_ids)
+             con_app         = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co
+             tup_con         = tupleDataCon Unboxed (length arg_tys)
+
+       ; MASSERT( null _exs ) -- Should have been caught by deepSplitCprType_maybe
 
        ; return (True
                 , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild
-                                                (DataAlt tup_con) args con_app
-                , \ body     -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app
+                                                (DataAlt tup_con) arg_ids con_app
+                , \ body     -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app
                 , ubx_tup_ty ) }
+  where
+    arg_tys   = dataConInstArgTys dc tc_args -- NB: No existentials!
+    str_marks = dataConRepStrictness dc
 
 mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
 -- (mkUnpackCase e co uniq Con args body)
@@ -1149,7 +1209,7 @@ mkUnpackCase scrut co mult uniq boxing_con unpk_args body
                     (DataAlt boxing_con) unpk_args body
   where
     casted_scrut = scrut `mkCast` co
-    bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict)
+    bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))
       -- An unpacking case can always be chosen linear, because the variables
       -- are always passed to a constructor. This limits the
 {-
@@ -1291,10 +1351,13 @@ mk_absent_let dflags fam_envs arg
               -- See also Note [Unique Determinism] in GHC.Types.Unique
     unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]
 
-mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id
+ww_prefix :: FastString
+ww_prefix = fsLit "ww"
+
+mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id
 -- The StrictnessMark comes form the data constructor and says
 -- whether this field is strict
 -- See Note [Record evaluated-ness in worker/wrapper]
-mk_ww_local uniq (Scaled w ty,str)
+mk_ww_local uniq str (Scaled w ty)
   = setCaseBndrEvald str $
-    mkSysLocalOrCoVar (fsLit "ww") uniq w ty
+    mkSysLocalOrCoVar ww_prefix uniq w ty


=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -58,8 +58,7 @@ module GHC.Core.TyCon(
         isKindTyCon, isLiftedTypeKindTyConName,
         isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,
 
-        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,
-        isDataSumTyCon_maybe,
+        isDataTyCon,
         isEnumerationTyCon,
         isNewTyCon, isAbstractTyCon,
         isFamilyTyCon, isOpenFamilyTyCon,
@@ -84,6 +83,7 @@ module GHC.Core.TyCon(
         tyConCType, tyConCType_maybe,
         tyConDataCons, tyConDataCons_maybe,
         tyConSingleDataCon_maybe, tyConSingleDataCon,
+        tyConAlgDataCons_maybe,
         tyConSingleAlgDataCon_maybe,
         tyConFamilySize,
         tyConStupidTheta,
@@ -143,7 +143,7 @@ import {-# SOURCE #-} GHC.Builtin.Types
    , multiplicityTyCon
    , vecCountTyCon, vecElemTyCon, liftedTypeKind )
 import {-# SOURCE #-} GHC.Core.DataCon
-   ( DataCon, dataConExTyCoVars, dataConFieldLabels
+   ( DataCon, dataConFieldLabels
    , dataConTyCon, dataConFullSig
    , isUnboxedSumDataCon )
 import GHC.Builtin.Uniques
@@ -1976,72 +1976,6 @@ unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co,
                            = Just (tvs, rhs, co)
 unwrapNewTyConEtad_maybe _ = Nothing
 
-isProductTyCon :: TyCon -> Bool
--- True of datatypes or newtypes that have
---   one, non-existential, data constructor
--- See Note [Product types]
-isProductTyCon tc@(AlgTyCon {})
-  = case algTcRhs tc of
-      TupleTyCon {} -> True
-      DataTyCon{ data_cons = [data_con] }
-                    -> null (dataConExTyCoVars data_con)
-      NewTyCon {}   -> True
-      _             -> False
-isProductTyCon _ = False
-
-isDataProductTyCon_maybe :: TyCon -> Maybe DataCon
--- True of datatypes (not newtypes) with
---   one, vanilla, data constructor
--- See Note [Product types]
-isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })
-  = case rhs of
-       DataTyCon { data_cons = [con] }
-         | null (dataConExTyCoVars con)  -- non-existential
-         -> Just con
-       TupleTyCon { data_con = con }
-         -> Just con
-       _ -> Nothing
-isDataProductTyCon_maybe _ = Nothing
-
-isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]
-isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })
-  = case rhs of
-      DataTyCon { data_cons = cons }
-        | cons `lengthExceeds` 1
-        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?
-        -> Just cons
-      SumTyCon { data_cons = cons }
-        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?
-        -> Just cons
-      _ -> Nothing
-isDataSumTyCon_maybe _ = Nothing
-
-{- Note [Product types]
-~~~~~~~~~~~~~~~~~~~~~~~
-A product type is
- * A data type (not a newtype)
- * With one, boxed data constructor
- * That binds no existential type variables
-
-The main point is that product types are amenable to unboxing for
-  * Strict function calls; we can transform
-        f (D a b) = e
-    to
-        fw a b = e
-    via the worker/wrapper transformation.  (Question: couldn't this
-    work for existentials too?)
-
-  * CPR for function results; we can transform
-        f x y = let ... in D a b
-    to
-        fw x y = let ... in (# a, b #)
-
-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.
--}
-
-
 -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?
 {-# INLINE isTypeSynonymTyCon #-}  -- See Note [Inlining coreView] in GHC.Core.Type
 isTypeSynonymTyCon :: TyCon -> Bool
@@ -2380,8 +2314,7 @@ tyConDataCons_maybe _ = Nothing
 -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@
 -- type with one alternative, a tuple type or a @newtype@ then that constructor
 -- is returned. If the 'TyCon' has more than one constructor, or represents a
--- primitive or function type constructor then @Nothing@ is returned. In any
--- other case, the function panics
+-- primitive or function type constructor then @Nothing@ is returned.
 tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon
 tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })
   = case rhs of
@@ -2391,21 +2324,29 @@ tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })
       _                             -> Nothing
 tyConSingleDataCon_maybe _           = Nothing
 
+-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'.
 tyConSingleDataCon :: TyCon -> DataCon
 tyConSingleDataCon tc
   = case tyConSingleDataCon_maybe tc of
       Just c  -> c
       Nothing -> pprPanic "tyConDataCon" (ppr tc)
 
+-- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes.
 tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon
--- Returns (Just con) for single-constructor
--- *algebraic* data types *not* newtypes
-tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })
-  = case rhs of
-      DataTyCon { data_cons = [c] } -> Just c
-      TupleTyCon { data_con = c }   -> Just c
-      _                             -> Nothing
-tyConSingleAlgDataCon_maybe _        = Nothing
+tyConSingleAlgDataCon_maybe tycon
+  | isNewTyCon tycon = Nothing
+  | otherwise        = tyConSingleDataCon_maybe tycon
+
+-- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type
+-- or a sum type with data constructors dcs. If the 'TyCon' has more than one
+-- constructor, or represents a primitive or function type constructor then
+-- @Nothing@ is returned.
+--
+-- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes.
+tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]
+tyConAlgDataCons_maybe tycon
+  | isNewTyCon tycon = Nothing
+  | otherwise        = tyConDataCons_maybe tycon
 
 -- | Determine the number of value constructors a 'TyCon' has. Panics if the
 -- 'TyCon' is not algebraic or a tuple


=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -245,7 +245,7 @@ toIfaceTyCon tc
       , Just tsort <- tupleSort tc'          = tsort
 
       | isUnboxedSumTyCon tc
-      , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)
+      , Just cons <- tyConDataCons_maybe tc  = IfaceSumTyCon (length cons)
 
       | otherwise                            = IfaceNormalTyCon
 


=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -771,8 +771,6 @@ isIrrefutableHsPat
          L _ (PatSynCon _pat)  -> False -- Conservative
          L _ (RealDataCon con) ->
            isJust (tyConSingleDataCon_maybe (dataConTyCon con))
-           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
-           -- the latter is false of existentials. See #4439
            && all goL (hsConPatArgs details)
     go (LitPat {})         = False
     go (NPat {})           = False


=====================================
compiler/GHC/HsToCore/Foreign/Call.hs
=====================================
@@ -350,7 +350,8 @@ resultWrapper result_ty
   -- Data types with a single constructor, which has a single arg
   -- This includes types like Ptr and ForeignPtr
   | Just (tycon, tycon_arg_tys) <- maybe_tc_app
-  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials
+  , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor
+  , null (dataConExTyCoVars data_con)                   -- no existentials
   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
   = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
        ; let marshal_con e  = Var (dataConWrapId data_con)


=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -737,7 +737,7 @@ is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
 is_flat_prod_pat (ConPat { pat_con  = L _ pcon
                          , pat_args = ps})
   | RealDataCon con <- pcon
-  , isProductTyCon (dataConTyCon con)
+  , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con)
   = all is_triv_lpat (hsConPatArgs ps)
 is_flat_prod_pat _ = False
 


=====================================
compiler/GHC/Tc/Deriv/Utils.hs
=====================================
@@ -928,8 +928,8 @@ cond_isEnumeration _ _ rep_tc
 
 cond_isProduct :: Condition
 cond_isProduct _ _ rep_tc
-  | isProductTyCon rep_tc = IsValid
-  | otherwise             = NotValid why
+  | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid
+  | otherwise                                 = NotValid why
   where
     why = quotes (pprSourceTyCon rep_tc) <+>
           text "must have precisely one constructor"


=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -55,6 +55,7 @@ module GHC.Types.Demand (
     PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
     -- ** Other operations
     peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
+    keepAliveDmdType,
 
     -- * Demand signatures
     StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
@@ -1196,6 +1197,11 @@ findIdDemand (DmdType fv _ res) id
 deferAfterPreciseException :: DmdType -> DmdType
 deferAfterPreciseException = lubDmdType exnDmdType
 
+-- | See 'keepAliveDmdEnv'.
+keepAliveDmdType :: DmdType -> VarSet -> DmdType
+keepAliveDmdType (DmdType fvs ds res) vars =
+  DmdType (fvs `keepAliveDmdEnv` vars) ds res
+
 {-
 Note [Demand type Divergence]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
testsuite/tests/simplCore/should_compile/T18013.stderr
=====================================
@@ -132,33 +132,58 @@ Result size of Tidy Core
   = {terms: 52, types: 106, coercions: 17, joins: 0/1}
 
 -- RHS size: {terms: 37, types: 87, coercions: 17, joins: 0/1}
-mapMaybeRule
+mapMaybeRule [InlPrag=[2]]
   :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b)
 [GblId,
  Arity=1,
- Str=<SU>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 150 10}]
+ Str=<SP(U,UCU(CS(CS(P(U,SP(U,U))))))>,
+ 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)
+         Tmpl= \ (@a) (@b) (w [Occ=Once1!] :: Rule IO a b) ->
+                 case w of { Rule @s ww1 ww2 [Occ=OnceL1!] ->
+                 T18013a.Rule
+                   @IO
+                   @(Maybe a)
+                   @(Maybe b)
+                   @s
+                   ww1
+                   ((\ (s2 [Occ=Once1] :: s)
+                       (a1 [Occ=Once1!] :: Maybe a)
+                       (s1 [Occ=Once2] :: GHC.Prim.State# GHC.Prim.RealWorld) ->
+                       case a1 of {
+                         Nothing ->
+                           (# s1, T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) #);
+                         Just x [Occ=Once1] ->
+                           case ((ww2 s2 x) `cast` <Co:4>) s1 of
+                           { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) ->
+                           case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] ->
+                           (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #)
+                           }
+                           }
+                       })
+                    `cast` <Co:13>)
+                 }}]
 mapMaybeRule
-  = \ (@a) (@b) (f :: Rule IO a b) ->
-      case f of { Rule @s t0 g ->
+  = \ (@a) (@b) (w :: Rule IO a b) ->
+      case w of { Rule @s ww1 ww2 ->
       let {
         lvl :: Result s (Maybe b)
         [LclId, Unf=OtherCon []]
-        lvl = T18013a.Result @s @(Maybe b) t0 (GHC.Maybe.Nothing @b) } in
+        lvl = T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) } in
       T18013a.Rule
         @IO
         @(Maybe a)
         @(Maybe b)
         @s
-        t0
+        ww1
         ((\ (s2 :: s)
             (a1 :: Maybe a)
             (s1 :: GHC.Prim.State# GHC.Prim.RealWorld) ->
             case a1 of {
               Nothing -> (# s1, lvl #);
               Just x ->
-                case ((g s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) ->
+                case ((ww2 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) ->
                 case ipv1 of { Result t2 c1 ->
                 (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #)
                 }


=====================================
testsuite/tests/stranal/should_compile/T18982.hs
=====================================
@@ -0,0 +1,41 @@
+{-# OPTIONS_GHC -O -fforce-recomp #-}
+{-# LANGUAGE GADTs #-}
+
+module T18982 where
+
+data Box a where
+  Box :: a -> Box a
+
+data Ex a where
+  Ex :: e -> a -> Ex a
+
+data GADT a where
+  GADT :: Int -> GADT Int
+
+data ExGADT a where
+  ExGADT :: (e ~ Int) => e -> Int -> ExGADT Int
+
+-- | Expected worker type:
+-- $wf :: Int# -> Int#
+f :: Box Int -> Int
+f (Box n) = n + 1
+{-# NOINLINE f #-}
+
+-- | Expected worker type:
+-- $wg :: forall {e}. e -> Int# -> Int#
+g :: Ex Int -> Int
+g (Ex e n) = e `seq` n + 1
+{-# NOINLINE g #-}
+
+-- | Expected worker type:
+-- $wh :: Int# -> Int#
+h :: GADT a -> Int
+h (GADT n) = n + 1
+{-# NOINLINE h #-}
+
+-- | Expected worker type:
+-- $wi :: forall {e}. e -> Int# -> Int#
+i :: ExGADT a -> Int
+i (ExGADT e n) = e `seq` n + 1
+{-# NOINLINE i #-}
+


=====================================
testsuite/tests/stranal/should_compile/T18982.stderr
=====================================
@@ -0,0 +1,246 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 311, types: 249, coercions: 4, joins: 0/0}
+
+-- RHS size: {terms: 8, types: 11, coercions: 1, joins: 0/0}
+T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int
+T18982.$WExGADT = \ (@e) (dt :: e ~ Int) (dt :: e) (dt :: Int) -> T18982.ExGADT @Int @e @~(<Int>_N :: Int GHC.Prim.~# Int) dt dt dt
+
+-- RHS size: {terms: 3, types: 2, coercions: 1, joins: 0/0}
+T18982.$WGADT :: Int %1 -> GADT Int
+T18982.$WGADT = \ (dt :: Int) -> T18982.GADT @Int @~(<Int>_N :: Int GHC.Prim.~# Int) dt
+
+-- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0}
+T18982.$WEx :: forall e a. e %1 -> a %1 -> Ex a
+T18982.$WEx = \ (@e) (@a) (dt :: e) (dt :: a) -> T18982.Ex @a @e dt dt
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$trModule4 :: GHC.Prim.Addr#
+T18982.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$trModule3 :: GHC.Types.TrName
+T18982.$trModule3 = GHC.Types.TrNameS T18982.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$trModule2 :: GHC.Prim.Addr#
+T18982.$trModule2 = "T18982"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$trModule1 :: GHC.Types.TrName
+T18982.$trModule1 = GHC.Types.TrNameS T18982.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18982.$trModule :: GHC.Types.Module
+T18982.$trModule = GHC.Types.Module T18982.$trModule3 T18982.$trModule1
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep :: GHC.Types.KindRep
+$krep = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1 :: GHC.Types.KindRep
+$krep1 = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep2 :: GHC.Types.KindRep
+$krep2 = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep3 :: [GHC.Types.KindRep]
+$krep3 = GHC.Types.: @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep4 :: [GHC.Types.KindRep]
+$krep4 = GHC.Types.: @GHC.Types.KindRep $krep2 $krep3
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep5 :: [GHC.Types.KindRep]
+$krep5 = GHC.Types.: @GHC.Types.KindRep GHC.Types.krep$* $krep4
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep6 :: GHC.Types.KindRep
+$krep6 = GHC.Types.KindRepTyConApp GHC.Types.$tc~ $krep5
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcBox2 :: GHC.Prim.Addr#
+T18982.$tcBox2 = "Box"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcBox1 :: GHC.Types.TrName
+T18982.$tcBox1 = GHC.Types.TrNameS T18982.$tcBox2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcBox :: GHC.Types.TyCon
+T18982.$tcBox = GHC.Types.TyCon 16948648223906549518## 2491460178135962649## T18982.$trModule T18982.$tcBox1 0# GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep7 :: [GHC.Types.KindRep]
+$krep7 = GHC.Types.: @GHC.Types.KindRep $krep2 (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep8 :: GHC.Types.KindRep
+$krep8 = GHC.Types.KindRepTyConApp T18982.$tcBox $krep7
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Box1 :: GHC.Types.KindRep
+T18982.$tc'Box1 = GHC.Types.KindRepFun $krep2 $krep8
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Box3 :: GHC.Prim.Addr#
+T18982.$tc'Box3 = "'Box"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Box2 :: GHC.Types.TrName
+T18982.$tc'Box2 = GHC.Types.TrNameS T18982.$tc'Box3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Box :: GHC.Types.TyCon
+T18982.$tc'Box = GHC.Types.TyCon 1412068769125067428## 8727214667407894081## T18982.$trModule T18982.$tc'Box2 1# T18982.$tc'Box1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcEx2 :: GHC.Prim.Addr#
+T18982.$tcEx2 = "Ex"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcEx1 :: GHC.Types.TrName
+T18982.$tcEx1 = GHC.Types.TrNameS T18982.$tcEx2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcEx :: GHC.Types.TyCon
+T18982.$tcEx = GHC.Types.TyCon 4376661818164435927## 18005417598910668817## T18982.$trModule T18982.$tcEx1 0# GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep9 :: [GHC.Types.KindRep]
+$krep9 = GHC.Types.: @GHC.Types.KindRep $krep1 (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep10 :: GHC.Types.KindRep
+$krep10 = GHC.Types.KindRepTyConApp T18982.$tcEx $krep9
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep11 :: GHC.Types.KindRep
+$krep11 = GHC.Types.KindRepFun $krep1 $krep10
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Ex1 :: GHC.Types.KindRep
+T18982.$tc'Ex1 = GHC.Types.KindRepFun $krep2 $krep11
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Ex3 :: GHC.Prim.Addr#
+T18982.$tc'Ex3 = "'Ex"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Ex2 :: GHC.Types.TrName
+T18982.$tc'Ex2 = GHC.Types.TrNameS T18982.$tc'Ex3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'Ex :: GHC.Types.TyCon
+T18982.$tc'Ex = GHC.Types.TyCon 14609381081172201359## 3077219645053200509## T18982.$trModule T18982.$tc'Ex2 2# T18982.$tc'Ex1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcGADT2 :: GHC.Prim.Addr#
+T18982.$tcGADT2 = "GADT"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcGADT1 :: GHC.Types.TrName
+T18982.$tcGADT1 = GHC.Types.TrNameS T18982.$tcGADT2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcGADT :: GHC.Types.TyCon
+T18982.$tcGADT = GHC.Types.TyCon 9243924476135839950## 5096619276488416461## T18982.$trModule T18982.$tcGADT1 0# GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep12 :: GHC.Types.KindRep
+$krep12 = GHC.Types.KindRepTyConApp T18982.$tcGADT $krep3
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'GADT1 :: GHC.Types.KindRep
+T18982.$tc'GADT1 = GHC.Types.KindRepFun $krep $krep12
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'GADT3 :: GHC.Prim.Addr#
+T18982.$tc'GADT3 = "'GADT"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'GADT2 :: GHC.Types.TrName
+T18982.$tc'GADT2 = GHC.Types.TrNameS T18982.$tc'GADT3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'GADT :: GHC.Types.TyCon
+T18982.$tc'GADT = GHC.Types.TyCon 2077850259354179864## 16731205864486799217## T18982.$trModule T18982.$tc'GADT2 0# T18982.$tc'GADT1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcExGADT2 :: GHC.Prim.Addr#
+T18982.$tcExGADT2 = "ExGADT"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcExGADT1 :: GHC.Types.TrName
+T18982.$tcExGADT1 = GHC.Types.TrNameS T18982.$tcExGADT2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tcExGADT :: GHC.Types.TyCon
+T18982.$tcExGADT = GHC.Types.TyCon 6470898418160489500## 10361108917441214060## T18982.$trModule T18982.$tcExGADT1 0# GHC.Types.krep$*Arr*
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep13 :: GHC.Types.KindRep
+$krep13 = GHC.Types.KindRepTyConApp T18982.$tcExGADT $krep3
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep14 :: GHC.Types.KindRep
+$krep14 = GHC.Types.KindRepFun $krep $krep13
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep15 :: GHC.Types.KindRep
+$krep15 = GHC.Types.KindRepFun $krep2 $krep14
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'ExGADT1 :: GHC.Types.KindRep
+T18982.$tc'ExGADT1 = GHC.Types.KindRepFun $krep6 $krep15
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'ExGADT3 :: GHC.Prim.Addr#
+T18982.$tc'ExGADT3 = "'ExGADT"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'ExGADT2 :: GHC.Types.TrName
+T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+T18982.$tc'ExGADT :: GHC.Types.TyCon
+T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049## 5503123603717080600## T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1
+
+-- RHS size: {terms: 11, types: 14, coercions: 0, joins: 0/0}
+T18982.$wi :: forall {a} {e}. (a GHC.Prim.~# Int) -> e -> GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# }
+
+-- RHS size: {terms: 15, types: 27, coercions: 1, joins: 0/0}
+i :: forall a. ExGADT a -> Int
+i = \ (@a) (w :: ExGADT a) -> case w of { ExGADT @e ww1 ww2 ww3 ww4 -> case ww4 of { GHC.Types.I# ww6 -> case T18982.$wi @a @e @~(ww1 :: a GHC.Prim.~# Int) ww3 ww6 of ww7 { __DEFAULT -> GHC.Types.I# ww7 } } }
+
+-- RHS size: {terms: 6, types: 10, coercions: 0, joins: 0/0}
+T18982.$wh :: forall {a}. (a GHC.Prim.~# Int) -> GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wh = \ (@a) (ww :: a GHC.Prim.~# Int) (ww1 :: GHC.Prim.Int#) -> GHC.Prim.+# ww1 1#
+
+-- RHS size: {terms: 14, types: 18, coercions: 1, joins: 0/0}
+h :: forall a. GADT a -> Int
+h = \ (@a) (w :: GADT a) -> case w of { GADT ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wh @a @~(ww1 :: a GHC.Prim.~# Int) ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
+
+-- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0}
+T18982.$wg :: forall {e}. e -> GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wg = \ (@e) (ww :: e) (ww1 :: GHC.Prim.Int#) -> case ww of { __DEFAULT -> GHC.Prim.+# ww1 1# }
+
+-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
+g :: Ex Int -> Int
+g = \ (w :: Ex Int) -> case w of { Ex @e ww1 ww2 -> case ww2 of { GHC.Types.I# ww4 -> case T18982.$wg @e ww1 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
+
+-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
+T18982.$wf :: GHC.Prim.Int# -> GHC.Prim.Int#
+T18982.$wf = \ (ww :: GHC.Prim.Int#) -> GHC.Prim.+# ww 1#
+
+-- RHS size: {terms: 13, types: 8, coercions: 0, joins: 0/0}
+f :: Box Int -> Int
+f = \ (w :: Box Int) -> case w of { Box ww1 -> case ww1 of { GHC.Types.I# ww3 -> case T18982.$wf ww3 of ww4 { __DEFAULT -> GHC.Types.I# ww4 } } }
+
+
+


=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -62,3 +62,5 @@ test('T18903',  [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppr
 test('T18894',  [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-stranal -dsuppress-uniques'])
 # We care about the Arity 2 on eta, as a result of the annotated Dmd
 test('T18894b',  [ grep_errmsg(r'Arity=2') ], compile, ['-ddump-stranal -dsuppress-uniques -fno-call-arity -dppr-cols=200'])
+# We care about the workers of f,g,h,i:
+test('T18982',  [ grep_errmsg(r'\$w. .*Int#$') ], compile, ['-dppr-cols=1000 -ddump-simpl -dsuppress-idinfo -dsuppress-uniques'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7ff359a55016727f6495f529a4c2964dda24db9...aeaa91260a3d6ae57605dfa415e56d2691e74ade

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a7ff359a55016727f6495f529a4c2964dda24db9...aeaa91260a3d6ae57605dfa415e56d2691e74ade
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201218/b631d50f/attachment-0001.html>


More information about the ghc-commits mailing list