[Git][ghc/ghc][wip/sgraf-dmdanal-stuff] 4 commits: DmdAnal: Annotate top-level function bindings with demands (#18894)
Sebastian Graf
gitlab at gitlab.haskell.org
Fri Dec 4 10:04:51 UTC 2020
Sebastian Graf pushed to branch wip/sgraf-dmdanal-stuff at Glasgow Haskell Compiler / GHC
Commits:
f5596240 by Sebastian Graf at 2020-12-04T09:45:18+01:00
DmdAnal: Annotate top-level function bindings with demands (#18894)
It's useful to annotate a non-exported top-level function like `g` in
```hs
module Lib (h) where
g :: Int -> Int -> (Int,Int)
g m 1 = (m, 0)
g m n = (2 * m, 2 `div` n)
{-# NOINLINE g #-}
h :: Int -> Int
h 1 = 0
h m
| odd m = snd (g m 2)
| otherwise = uncurry (+) (g 2 m)
```
with its demand `UCU(CS(P(1P(U),SP(U))`, which tells us that whenever `g` was
called, the second component of the returned pair was evaluated strictly.
Since #18903 we do so for local functions, where we can see all calls.
For top-level functions, we can assume that all *exported* functions are
demanded according to `topDmd` and thus get sound demands for
non-exported top-level functions.
The demand on `g` is crucial information for Nested CPR, which may the
go on and unbox `g` for the second pair component. That is true even if
that pair component may diverge, as is the case for the call site `g 13
0`, which throws a div-by-zero exception.
In `T18894b`, you can even see the new demand annotation enabling us to
eta-expand a function that we wouldn't be able to eta-expand without
Call Arity.
We only track bindings of function type in order not to risk huge compile-time
regressions, see `isInterestingTopLevelFn`.
There was a CoreLint check that rejected strict demand annotations on
recursive or top-level bindings, which seems completely unjustified.
All the cases I investigated were fine, so I removed it.
Fixes #18894.
- - - - -
20d741fa by Sebastian Graf at 2020-12-04T09:45:18+01:00
Demand: Simplify `CU(U)` to `U` (#19005)
Both sub-demands encode the same information.
This is a trivial change and already affects a few regression tests
(e.g. `T5075`), so no separate regression test is necessary.
- - - - -
84bef92f by Sebastian Graf at 2020-12-04T11:03:31+01:00
DmdAnal: Keep alive RULE vars in LetUp (#18971)
I also took the liberty to refactor the logic around `ruleFVs`.
- - - - -
0f32bf5e by Sebastian Graf at 2020-12-04T11:04:30+01:00
WorkWrap: Unbox constructors with existentials (#18982)
I found that by relaxing the "no existential" checks in
`isDataProductType_maybe` and `isDataSumType_maybe`, the former becomes
identical to `tyConSingleAlgDataCon_maybe`. So I deleted both and
introduced a new function, `tyConAlgDataCons_maybe` for the sum case.
I cleaned up a couple of call sites, some of which weren't very explicit
about whether they cared for existentials or not.
Most of the new stuff happens in worker/wrapper, where handling of
existentials means more substitution work because we have to clone
the existential binders of the DataCon when matching on it in the
unboxing `Case`.
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.
- - - - -
30 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Foreign/Call.hs
- compiler/GHC/HsToCore/Foreign/Decl.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/Deriv/Utils.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Info.hs
- testsuite/tests/arityanal/should_compile/Arity11.stderr
- testsuite/tests/arityanal/should_compile/Arity16.stderr
- testsuite/tests/simplCore/should_compile/T18013.stderr
- + testsuite/tests/stranal/should_compile/T18894.hs
- + testsuite/tests/stranal/should_compile/T18894.stderr
- + testsuite/tests/stranal/should_compile/T18894b.hs
- + testsuite/tests/stranal/should_compile/T18894b.stderr
- + testsuite/tests/stranal/should_compile/T18982.hs
- + testsuite/tests/stranal/should_compile/T18982.stderr
- testsuite/tests/stranal/should_compile/all.T
- testsuite/tests/stranal/sigs/T5075.stderr
Changes:
=====================================
compiler/GHC/Core/DataCon.hs
=====================================
@@ -48,7 +48,7 @@ module GHC.Core.DataCon (
dataConImplicitTyThings,
dataConRepStrictness, dataConImplBangs, dataConBoxer,
- splitDataProductType_maybe,
+ splitNonExDataProductType_maybe,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon,
@@ -1564,29 +1564,28 @@ 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@
-splitDataProductType_maybe
+-- Whether the type is a @data@ type or a @newtype at .
+splitNonExDataProductType_maybe
:: Type -- ^ A product type, perhaps
-> Maybe (TyCon, -- The type constructor
[Type], -- Type args of the tycon
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
+splitNonExDataProductType_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,
ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet, mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
- ruleRhsFreeVars, ruleRhsFreeIds,
+ ruleRhsFreeVars, rulesRhsFreeIds,
expr_fvs,
@@ -450,46 +451,75 @@ 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)
+-- | Just the variables free on the *rhs* of a rule
idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
--- Just the variables free on the *rhs* of a rule
+-- SG: Seems very ad-hoc. Why doesn't this call ruleFV? It does something
+-- with ru_fn, probably related to Hack [Rule free var hack].
idRuleRhsVars is_active id
= mapUnionVarSet get_fvs (idCoreRules id)
where
@@ -503,35 +533,6 @@ idRuleRhsVars is_active id
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 left hand side of a rule
--- and returns them as a non-deterministic set
-ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
- = fvVarSet $ filterFV isLocalId $
- addBndrs bndrs $ exprs_fvs args
-
{-
Note [Rule free var hack] (Not a hack any more)
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -661,6 +662,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/Lint.hs
=====================================
@@ -623,14 +623,6 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
|| exprIsTickedString rhs)
(badBndrTyMsg binder (text "unlifted"))
- -- Check that if the binder is top-level or recursive, it's not
- -- demanded. Primitive string literals are exempt as there is no
- -- computation to perform, see Note [Core top-level string literals].
- ; checkL (not (isStrictId binder)
- || (isNonRec rec_flag && not (isTopLevel top_lvl))
- || exprIsTickedString rhs)
- (mkStrictMsg binder)
-
-- Check that if the binder is at the top level and has type Addr#,
-- that it is a string literal, see
-- Note [Core top-level string literals].
@@ -3119,13 +3111,6 @@ badBndrTyMsg binder what
= vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder
, text "Binder's type:" <+> ppr (idType binder) ]
-mkStrictMsg :: Id -> MsgDoc
-mkStrictMsg binder
- = vcat [hsep [text "Recursive or top-level binder has strict demand info:",
- ppr binder],
- hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]
- ]
-
mkNonTopExportedMsg :: Id -> MsgDoc
mkNonTopExportedMsg binder
= hsep [text "Non-top-level binder is marked as exported:", ppr binder]
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -446,14 +446,13 @@ 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.
+ -- CPR'ing existentials would need first class existentials/dependent sums
+ -- to exploit, so we return topCprType here.
| otherwise = topCprType
-- We could have much deeper CPR info here with Nested CPR, which could
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -34,9 +34,10 @@ 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 )
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Data.Maybe ( isJust )
@@ -64,28 +65,54 @@ data DmdAnalOpts = DmdAnalOpts
--
-- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note
-- [Stamp out space leaks in demand analysis])
-dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram
-dmdAnalProgram opts fam_envs binds = binds_plus_dmds
- where
- env = emptyAnalEnv opts fam_envs
- binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds
-
--- Analyse a (group of) top-level binding(s)
-dmdAnalTopBind :: AnalEnv
- -> CoreBind
- -> (AnalEnv, CoreBind)
-dmdAnalTopBind env (NonRec id rhs)
- = ( extendAnalEnv TopLevel env id sig
- , NonRec (setIdStrictness id sig) rhs')
+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
+dmdAnalProgram opts fam_envs rules binds
+ = snd $ go (emptyAnalEnv opts fam_envs) binds
where
- ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs
-
-dmdAnalTopBind env (Rec pairs)
- = (env', Rec pairs')
- where
- (env', _, pairs') = dmdFix TopLevel env topSubDmd pairs
- -- We get two iterations automatically
- -- c.f. the NonRec case above
+ -- See Note [Analysing top-level bindings]
+ -- TLDR; We analyse them like
+ -- let ex1 = ... in (ex1, let nex1 = ... in let ex2 = ... in (ex2, ...)))
+ -- where ex* are exported (or RULE mentions) and nex* are not.
+ go _ [] = (nopDmdType, [])
+ go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body
+ where
+ anal_body env'
+ | (body_ty, bs') <- go env' bs
+ = (add_exported_uses env' body_ty (bindersOf b), bs')
+
+ cons_up :: (a, b, [b]) -> (a, [b])
+ cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs')
+
+ add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
+ add_exported_uses env = foldl' (add_exported_use env)
+
+ -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@
+ -- corresponds to the demand type of @(id, e)@, but is a lot more direct.
+ -- See Note [Analysing top-level bindings].
+ add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType
+ add_exported_use env dmd_ty id
+ | isExportedId id || elemVarSet id rule_fvs
+ -- See Note [Absence analysis for stable unfoldings and RULES]
+ = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
+ | otherwise = dmd_ty
+
+ rule_fvs :: IdSet
+ rule_fvs = rulesRhsFreeIds rules
+
+-- | Whether we want to store demands on a top-level Id or just default
+-- to 'topDmd'.
+--
+-- Basically, we want to now how top-level *functions* are *used*
+-- (e.g. called), but aren't interested in whether they were called strictly
+-- or not. Other top-level bindings are boring.
+isInterestingTopLevelFn :: Id -> Bool
+-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642
+-- (which is dominated by the Simplifier) at no gain in analysis precision.
+-- If there was a gain, that regression might be acceptable.
+-- Plus, we could use LetUp for thunks and share some code with local let
+-- bindings.
+isInterestingTopLevelFn id =
+ typeArity (idType id) `lengthExceeds` 0
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -105,8 +132,56 @@ generation would hold on to an extra copy of the Core program, via
unforced thunks in demand or strictness information; and it is the
most memory-intensive part of the compilation process, so this added
seqBinds makes a big difference in peak memory usage.
--}
+Note [Analysing top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a CoreProgram like
+ e1 = ...
+ n1 = ...
+ e2 = \a b -> ... fst (n1 a b) ...
+ n2 = \c d -> ... snd (e2 c d) ...
+ ...
+where e* are exported, but n* are not.
+Intuitively, we can see that @n1@ is only ever called with two arguments
+and in every call site, the first component of the result of the call
+is evaluated. Thus, we'd like it to have idDemandInfo @UCU(C1(P(SU,A))@.
+
+(This can be exploited by a Nested CPR pass which may then unbox the
+first component of the pair returned from @n1 at . Or if @n1@ had arity
+1 before, we may now eta-expand to arity 2.)
+
+NB: We may *not* give e2 a similar annotation, because it is exported and
+external callers might use it in arbitrary ways, expressed by 'topDmd'.
+
+How do we get this result? Answer: By analysing the program as if it was a let
+expression of this form:
+ let e1 = ... in
+ (e1, let n1 = ... in
+ ( let e2 = ... in
+ (e2, let n2 = ... in
+ ( ...))))
+E.g. putting all bindings in nested lets, where whenever it binds an exported
+binding, the body is a *pair* of an occurrence of the exported binder and
+the other nested lets. Of course, we will not actually build that CoreExpr!
+Instead we faithfully simulate analysis of said expression by adding the
+free variable 'DmdEnv' of @e*@'s strictness signatures to the 'DmdType' we
+get from analysing the nested bindings.
+
+You might also wonder why we didn't analyse in terms of the simpler
+ let e1 = ... in
+ let n1 = ... in
+ let e2 = ... in
+ let n2 = ... in
+ (e1,e2, ...)
+The reason is analysis performance: If @e1@ uses many free variables, we'll
+unnecessarily carry their demands around with us from the moment we analyse
+the pair to the moment we bubble back up to the binding for @e1 at .
+This blows up e.g. @T10370 at .
+
+A final note about variables occuring free in RULE RHSs: They are to be handled
+pretty much like exported Ids.
+See also Note [Absence analysis for stable unfoldings and RULES]
+-}
{-
************************************************************************
@@ -114,7 +189,105 @@ seqBinds makes a big difference in peak memory usage.
\subsection{The analyser itself}
* *
************************************************************************
+-}
+
+-- | Analyse a binding group and its \"body\", e.g. where it is in scope.
+--
+-- It calls a function that knows how to analyse this \"body\" given
+-- an 'AnalEnv' with updated demand signatures for the binding group
+-- (reflecting their 'idStrictnessInfo') and expects to receive a
+-- 'DmdType' in return, which it uses to annotate the binding group with their
+-- 'idDemandInfo'.
+dmdAnalBind
+ :: TopLevelFlag
+ -> AnalEnv
+ -> SubDemand -- ^ Demand put on the "body"
+ -- (important for join points)
+ -> CoreBind
+ -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.
+ -- where the binding is in scope
+ -> (DmdType, CoreBind, a)
+dmdAnalBind top_lvl env dmd bind anal_body = case bind of
+ NonRec id rhs
+ | useLetUp top_lvl id
+ -> dmdAnalBindLetUp top_lvl env id rhs anal_body
+ _ -> dmdAnalBindLetDown top_lvl env dmd bind anal_body
+
+-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
+-- with 'topDmd', the rest with the given demand.
+setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id
+setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of
+ TopLevel | not (isInterestingTopLevelFn id) -> topDmd
+ _ -> dmd
+
+-- | Let bindings can be processed in two ways:
+-- Down (RHS before body) or Up (body before RHS).
+-- This function handles the up variant.
+--
+-- It is very simple. For let x = rhs in body
+-- * Demand-analyse 'body' in the current environment
+-- * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
+-- * Demand-analyse 'rhs' in 'rhs_dmd'
+--
+-- This is used for a non-recursive local let without manifest lambdas (see
+-- 'useLetUp').
+--
+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)
+dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')
+ where
+ (body_ty, body') = anal_body env
+ (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
+ -- 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).
+-- This function handles the down variant.
+--
+-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses
+-- that at call sites in the body.
+--
+-- It is used for toplevel definitions, recursive definitions and local
+-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').
+-- Local non-recursive definitions without a lambda are handled with LetUp.
+--
+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)
+dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
+ NonRec id rhs
+ | (env', lazy_fv, id1, rhs1) <-
+ dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs
+ -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)
+ Rec pairs
+ | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs
+ -> do_rest env' lazy_fv pairs' Rec
+ where
+ do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')
+ where
+ (body_ty, body') = anal_body env'
+ -- see Note [Lazy and unleashable free variables]
+ dmd_ty = addLazyFVs body_ty lazy_fv
+ (!final_ty, id_dmds) = findBndrsDmds env' dmd_ty (map fst pairs1)
+ pairs2 = zipWith do_one pairs1 id_dmds
+ do_one (id', rhs') dmd = (setBindIdDemandInfo top_lvl id' dmd, rhs')
+ -- If the actual demand is better than the vanilla call
+ -- demand, you might think that we might do better to re-analyse
+ -- the RHS with the stronger demand.
+ -- But (a) That seldom happens, because it means that *every* path in
+ -- the body of the let has to use that stronger demand
+ -- (b) It often happens temporarily in when fixpointing, because
+ -- the recursive function at first seems to place a massive demand.
+ -- But we don't want to go to extra work when the function will
+ -- probably iterate to something less demanding.
+ -- In practice, all the times the actual demand on id2 is more than
+ -- the vanilla call demand seem to be due to (b). So we don't
+ -- bother to re-analyse the RHS.
+{-
Note [Ensure demand is strict]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's important not to analyse e with a lazy demand because
@@ -194,7 +367,7 @@ dmdAnal' env dmd (App fun arg)
-- Crucially, coercions /are/ handled here, because they are
-- value arguments (#10288)
let
- call_dmd = mkCallDmd dmd
+ call_dmd = mkCalledOnceDmd dmd
(fun_ty, fun') = dmdAnal env call_dmd fun
(arg_dmd, res_ty) = splitDmdTy fun_ty
(arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
@@ -227,8 +400,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
@@ -267,8 +440,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
@@ -295,60 +468,11 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
-- , text "res_ty" <+> ppr res_ty ]) $
(res_ty, Case scrut' case_bndr' ty alts')
--- Let bindings can be processed in two ways:
--- Down (RHS before body) or Up (body before RHS).
--- The following case handle the up variant.
---
--- It is very simple. For let x = rhs in body
--- * Demand-analyse 'body' in the current environment
--- * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
--- * Demand-analyse 'rhs' in 'rhs_dmd'
---
--- This is used for a non-recursive local let without manifest lambdas.
--- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnal' env dmd (Let (NonRec id rhs) body)
- | useLetUp id
- = (final_ty, Let (NonRec id' rhs') body')
+dmdAnal' env dmd (Let bind body)
+ = (final_ty, Let bind' body')
where
- (body_ty, body') = dmdAnal env dmd body
- (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
- id' = setIdDemandInfo id id_dmd
-
- (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
- final_ty = body_ty' `plusDmdType` rhs_ty
-
-dmdAnal' env dmd (Let (NonRec id rhs) body)
- = (body_ty2, Let (NonRec id2 rhs') body')
- where
- (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
- id1 = setIdStrictness id sig
- env1 = extendAnalEnv NotTopLevel env id sig
- (body_ty, body') = dmdAnal env1 dmd body
- (body_ty1, id2) = annotateBndr env body_ty id1
- body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
-
- -- If the actual demand is better than the vanilla call
- -- demand, you might think that we might do better to re-analyse
- -- the RHS with the stronger demand.
- -- But (a) That seldom happens, because it means that *every* path in
- -- the body of the let has to use that stronger demand
- -- (b) It often happens temporarily in when fixpointing, because
- -- the recursive function at first seems to place a massive demand.
- -- But we don't want to go to extra work when the function will
- -- probably iterate to something less demanding.
- -- In practice, all the times the actual demand on id2 is more than
- -- the vanilla call demand seem to be due to (b). So we don't
- -- bother to re-analyse the RHS.
-
-dmdAnal' env dmd (Let (Rec pairs) body)
- = let
- (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
- (body_ty, body') = dmdAnal env' dmd body
- body_ty1 = deleteFVs body_ty (map fst pairs)
- body_ty2 = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
- in
- body_ty2 `seq`
- (body_ty2, Let (Rec pairs') body')
+ (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'
+ go' env' = dmdAnal env' dmd body
-- | A simple, syntactic analysis of whether an expression MAY throw a precise
-- exception when evaluated. It's always sound to return 'True'.
@@ -377,10 +501,11 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool
forcesRealWorld fam_envs ty
| ty `eqType` realWorldStatePrimTy
= True
- | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
+ | Just DataConAppContext{ dcac_dc = dc, dcac_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
@@ -582,9 +707,13 @@ dmdTransform env var dmd
| Just (sig, top_lvl) <- lookupSigEnv env var
, let fn_ty = dmdTransformSig sig dmd
= -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
- if isTopLevel top_lvl
- then fn_ty -- Don't record demand on top-level things
- else addVarDmd fn_ty var (C_11 :* dmd)
+ case top_lvl of
+ NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd)
+ TopLevel
+ | isInterestingTopLevelFn var
+ -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness
+ | otherwise
+ -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-- Everything else:
-- * Local let binders for which we use LetUp (cf. 'useLetUp')
-- * Lambda binders
@@ -599,46 +728,46 @@ dmdTransform env var dmd
* *
********************************************************************* -}
--- Let bindings can be processed in two ways:
--- Down (RHS before body) or Up (body before RHS).
--- dmdAnalRhsLetDown implements the Down variant:
--- * assuming a demand of <L,U>
+-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature
+-- for the LetDown rule. It works as follows:
+--
+-- * assuming a demand of <U>
-- * looking at the definition
-- * determining a strictness signature
--
--- It is used for toplevel definition, recursive definitions and local
--- non-recursive definitions that have manifest lambdas.
--- Local non-recursive definitions without a lambda are handled with LetUp.
---
--- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalRhsLetDown
- :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
+-- Since it assumed a demand of <U>, the resulting signature is applicable at
+-- any call site.
+dmdAnalRhsSig
+ :: TopLevelFlag
+ -> RecFlag
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
- -> (DmdEnv, StrictSig, CoreExpr)
+ -> (AnalEnv, DmdEnv, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
-dmdAnalRhsLetDown rec_flag env let_dmd id rhs
- = -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
- (lazy_fv, sig, rhs')
+dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
+ = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
+ (env', lazy_fv, id', rhs')
where
rhs_arity = idArity id
+ -- See Note [Demand signatures are computed for a threshold demand based on idArity]
rhs_dmd -- See Note [Demand analysis for join points]
-- See Note [Invariants on join points] invariant 2b, in GHC.Core
-- rhs_arity matches the join arity of the join point
| isJoinId id
- = mkCallDmds rhs_arity let_dmd
+ = mkCalledOnceDmds rhs_arity let_dmd
| otherwise
- -- NB: rhs_arity
- -- See Note [Demand signatures are computed for a threshold demand based on idArity]
- = mkRhsDmd env rhs_arity rhs
+ = mkCalledOnceDmds rhs_arity topSubDmd
(rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs
DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
+ id' = id `setIdStrictness` sig
+ env' = extendAnalEnv top_lvl env id' sig
+
-- See Note [Aggregated demand for cardinality]
-- FIXME: That Note doesn't explain the following lines at all. The reason
-- is really much different: When we have a recursive function, we'd
@@ -651,31 +780,15 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-- we'd have to do an additional iteration. reuseEnv makes sure that
-- we never get used-once info for FVs of recursive functions.
rhs_fv1 = case rec_flag of
- Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
- Nothing -> rhs_fv
+ 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
-
--- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for
--- unleashing on the given function's @rhs@, by creating
--- a call demand of @rhs_arity@
--- See Historical Note [Product demands for function body]
-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand
-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd
-
-- | 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).
@@ -720,8 +833,8 @@ mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd
-- * For a more convincing example with join points, see Note [Demand analysis
-- for join points].
--
-useLetUp :: Var -> Bool
-useLetUp f = idArity f == 0 && not (isJoinId f)
+useLetUp :: TopLevelFlag -> Var -> Bool
+useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f)
{- Note [Demand analysis for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -939,8 +1052,6 @@ dmdFix :: TopLevelFlag
dmdFix top_lvl env let_dmd orig_pairs
= loop 1 initial_pairs
where
- bndrs = map fst orig_pairs
-
-- See Note [Initialising strictness]
initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
| otherwise = orig_pairs
@@ -990,10 +1101,8 @@ dmdFix top_lvl env let_dmd orig_pairs
= -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $
((env', lazy_fv'), (id', rhs'))
where
- (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
- lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
- env' = extendAnalEnv top_lvl env id sig
- id' = setIdStrictness id sig
+ (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
+ lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
@@ -1090,7 +1199,7 @@ addLazyFVs dmd_ty lazy_fvs
-- demand with the bottom coming up from 'error'
--
-- I got a loop in the fixpointer without this, due to an interaction
- -- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was
+ -- with the lazy_fv filtering in dmdAnalRhsSig. Roughly, it was
-- letrec f n x
-- = letrec g y = x `fatbar`
-- letrec h z = z + ...g...
@@ -1156,10 +1265,6 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id
main_ty = addDemand dmd dmd_ty'
(dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
-deleteFVs :: DmdType -> [Var] -> DmdType
-deleteFVs (DmdType fvs dmds res) bndrs
- = DmdType (delVarEnvList fvs bndrs) dmds res
-
{-
Note [NOINLINE and strictness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -65,6 +65,7 @@ import GHC.Types.SrcLoc
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
+import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
@@ -495,7 +496,7 @@ doCorePass CoreDoExitify = {-# SCC "Exitify" #-}
doPass exitifyProgram
doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}
- doPassDFM dmdAnal
+ doPassDFRM dmdAnal
doCorePass CoreDoCpr = {-# SCC "CprAnal" #-}
doPassDFM cprAnalProgram
@@ -575,6 +576,13 @@ doPassDFM do_pass guts = do
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
doPassM (liftIO . do_pass dflags fam_envs) guts
+doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFRM do_pass guts = do
+ dflags <- getDynFlags
+ p_fam_env <- getPackageFamInstEnv
+ let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+ doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts
+
doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFU do_pass guts = do
dflags <- getDynFlags
@@ -1088,13 +1096,13 @@ transferIdInfo exported_id local_id
-dmdAnal :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
-dmdAnal dflags fam_envs binds = do
+dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
+dmdAnal dflags fam_envs rules binds = do
let opts = DmdAnalOpts
{ dmd_strict_dicts = gopt Opt_DictsStrict dflags
}
- binds_plus_dmds = dmdAnalProgram opts fam_envs binds
+ binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds
Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
- dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds
+ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds
-- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
seqBinds binds_plus_dmds `seq` return binds_plus_dmds
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -598,11 +598,10 @@ addJoinFlts = appOL
mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats into a single Rec group,
-- They must either all be lifted LetFloats or all JoinFloats
-mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff
+mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
, sfJoinFloats = jbs
, sfInScope = in_scope })
- = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
- ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
+ = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
SimplFloats { sfLetFloats = floats'
, sfJoinFloats = jfloats'
, sfInScope = in_scope }
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -484,7 +484,7 @@ tryWW dflags fam_envs is_rec fn_id rhs
| is_fun && is_eta_exp
= splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs
- | is_thunk -- See Note [Thunk splitting]
+ | isNonRec is_rec, is_thunk -- See Note [Thunk splitting]
= splitThunk dflags fam_envs is_rec new_fn_id rhs
| otherwise
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -609,50 +609,75 @@ mkWWstr_one dflags fam_envs has_inlineable_prag arg
wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)
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 dcac at DataConAppContext{ dcac_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
+ , cs `lengthIs` arity
-> Just (cs, dcac)
_ -> 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
+-- | Like 'dataConInstArgTys', but handles existentials by cloning and returning
+-- the freshened 'TyCoVar's in addition to the instantiated argument types.
+--
+-- The cloning needs a 'UniqSupply'.
+dataConCloneExAndInstArgTys :: DataCon -> [Type] -> UniqSupply -> ([TyCoVar], [Scaled Type])
+dataConCloneExAndInstArgTys dc tc_args us = (ex_tvs', arg_tys)
+ where
+ subst_univ = zipTvSubst (dataConUnivTyVars dc) tc_args
+ (subst, ex_tvs') = cloneTyVarBndrs subst_univ (dataConExTyCoVars dc) us
+ -- the following line is straight from 'dataConInstArgTys'
+ arg_tys = mapScaledType (substTy subst) <$> dataConRepArgTys dc
+
+-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
+-- the 'DataCon' may not have existentials. The lack of cloning the existentials
+-- compared to 'dataConCloneExAndInstArgTys' makes this function \"dubious\";
+-- only use it where type variables aren't substituted!
+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Scaled 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 = mapScaledType (substTy subst) <$> dataConRepArgTys dc
+
unbox_one :: DynFlags -> FamInstEnvs -> Var
-> [Demand]
-> DataConAppContext
-> 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
+ DataConAppContext { dcac_dc = dc, dcac_tc_args = tc_args
, 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
+ = do { (ex_tvs', arg_tys) <- dataConCloneExAndInstArgTys dc tc_args <$> getUniqueSupplyM
+ ; (case_bndr_uniq:arg_uniqs) <- getUniquesM
+ ; let scaled_arg_tys = map (scaleScaled (idMult arg)) arg_tys
+ str_marks = dataConRepStrictness dc
+ -- See Note [Add demands for strict constructors]
+ cs' = addDataConStrictness dc cs
+ arg_ids = zipWithEqual "unbox_one" setIdDemandInfo
+ (zipWith3 mk_ww_local arg_uniqs str_marks scaled_arg_tys)
+ 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,72 +957,67 @@ 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' application 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)
+-- > DataConAppContext Just [Int] (co :: Maybe Int ~ First Int)
--
-- represents
--
--- > Just @Int (_1 :: Int) |> co :: First Int
+-- > (Just @_1 _2 :: Maybe Int) |> co :: First Int
--
--- 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
+ { dcac_dc :: !DataCon
+ , dcac_tc_args :: ![Type]
+ , dcac_co :: !Coercion
}
+-- | 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.
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]
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 DataConAppContext { dcac_dc = con
+ , dcac_tc_args = tc_args
+ , dcac_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 .
+deepSplitCprType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext
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 [Product types] in "GHC.Core.TyCon"
+ -- 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_tc_args = tc_args
, dcac_co = co }
deepSplitCprType_maybe _ _ _ = Nothing
@@ -1035,13 +1055,15 @@ 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.
+ = TsProd (map (go rec_tc . scaledThing) (dubiousDataConInstArgTys con tc_args))
| Just (ty', _) <- instNewTyCon_maybe tc tc_args
, Just rec_tc <- checkRecTc rec_tc tc
@@ -1093,25 +1115,26 @@ mkWWcpr opt_CprAnal fam_envs body_ty cpr
mkWWcpr_help :: DataConAppContext
-> 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 (DataConAppContext { dcac_dc = dc, dcac_tc_args = tc_args
+ , dcac_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
@@ -1124,18 +1147,21 @@ mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys
-- 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
+ ; let wrap_wild = mk_ww_local wild_uniq MarkedStrict (linear ubx_tup_ty)
+ arg_ids = zipWith3 mk_ww_local uniqs str_marks 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
+ 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)
; 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 One 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 +1175,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
{-
@@ -1275,10 +1301,14 @@ mk_absent_let dflags fam_envs arg
abs_rhs = mkAbsentErrorApp arg_ty msg
msg = showSDoc (gopt_set dflags Opt_SuppressUniques)
- (ppr arg <+> ppr (idType arg) <+> file_msg)
+ (vcat
+ [ text "Arg:" <+> ppr arg
+ , text "Type:" <+> ppr arg_ty
+ , file_msg
+ ])
file_msg = case outputFile dflags of
Nothing -> empty
- Just f -> text "in output file " <+> quotes (text f)
+ Just f -> text "In output file " <+> quotes (text f)
-- We need to suppress uniques here because otherwise they'd
-- end up in the generated code as strings. This is bad for
-- determinism, because with different uniques the strings
@@ -1287,10 +1317,10 @@ 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
+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
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -21,7 +21,7 @@ import GHC.Core
import GHC.Core.Seq ( seqUnfolding )
import GHC.Types.Id
import GHC.Types.Id.Info
-import GHC.Types.Demand ( zapUsageEnvSig )
+import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Core.Type ( tidyType, tidyVarBndr )
import GHC.Core.Coercion ( tidyCo )
import GHC.Types.Var
@@ -206,7 +206,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
new_info = vanillaIdInfo
`setOccInfo` occInfo old_info
`setArityInfo` arityInfo old_info
- `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)
+ `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)
`setDemandInfo` demandInfo old_info
`setInlinePragInfo` inlinePragInfo old_info
`setUnfoldingInfo` new_unf
=====================================
compiler/GHC/Core/TyCon.hs
=====================================
@@ -58,8 +58,7 @@ module GHC.Core.TyCon(
isKindTyCon, isLiftedTypeKindTyConName,
isTauTyCon, isFamFreeTyCon,
- 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
@@ -1970,72 +1970,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
@@ -2363,8 +2297,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
@@ -2374,21 +2307,31 @@ 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.
+--
+-- These are the 'TyCon's we want to unbox. See Note [Product types].
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
@@ -2408,6 +2351,31 @@ algTyConRhs :: TyCon -> AlgTyConRhs
algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs
algTyConRhs other = pprPanic "algTyConRhs" (ppr other)
+{- Note [Product types]
+~~~~~~~~~~~~~~~~~~~~~~~
+A product type is
+ * A data type (not a newtype)
+ * With one data constructor
+
+The main point is that product types are amenable to unboxing for
+ * Strict function calls; we can transform
+ f (D @ex a b) = e
+ to
+ fw @ex a b = e
+ via the worker/wrapper transformation.
+
+ * CPR for function results (if the data con has no existentials); 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.
+-}
+
+
-- | Extract type variable naming the result of injective type family
tyConFamilyResVar_maybe :: TyCon -> Maybe Name
tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res
=====================================
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
=====================================
@@ -195,7 +195,7 @@ unboxArg arg
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
- maybe_product_type = splitDataProductType_maybe arg_ty
+ maybe_product_type = splitNonExDataProductType_maybe arg_ty
is_product_type = isJust maybe_product_type
Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type
data_con_arg_tys = map scaledThing scaled_data_con_arg_tys
@@ -353,7 +353,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 { dflags <- getDynFlags
; let platform = targetPlatform dflags
=====================================
compiler/GHC/HsToCore/Foreign/Decl.hs
=====================================
@@ -830,7 +830,7 @@ getPrimTyOf ty
-- Except for Bool, the types we are interested in have a single constructor
-- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
| otherwise =
- case splitDataProductType_maybe rep_ty of
+ case splitNonExDataProductType_maybe rep_ty of
Just (_, _, data_con, [Scaled _ prim_ty]) ->
ASSERT(dataConSourceArity data_con == 1)
ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
=====================================
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
=====================================
@@ -34,7 +34,7 @@ module GHC.Types.Demand (
lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
-- ** Other @Demand@ operations
oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,
- peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
+ peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,
addCaseBndrDmd,
-- ** Extracting one-shot information
argOneShots, argsOneShots, saturatedByOneShots,
@@ -55,6 +55,7 @@ module GHC.Types.Demand (
PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
-- ** Other operations
peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
+ keepAliveDmdType,
-- * Demand signatures
StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
@@ -73,7 +74,7 @@ module GHC.Types.Demand (
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
-- * Zapping usage information
- zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig
+ zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig
) where
#include "HsVersions.h"
@@ -89,7 +90,7 @@ import GHC.Data.Maybe ( orElse )
import GHC.Core.Type ( Type )
import GHC.Core.TyCon ( isNewTyCon, isClassTyCon )
-import GHC.Core.DataCon ( splitDataProductType_maybe )
+import GHC.Core.DataCon ( splitNonExDataProductType_maybe )
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Utils.Binary
@@ -278,7 +279,8 @@ data SubDemand
-- ^ @Call n sd@ describes the evaluation context of @n@ function
-- applications, where every individual result is evaluated according to @sd at .
-- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].
- -- Used only for values of function type.
+ -- Used only for values of function type. Use the smart constructor 'mkCall'
+ -- whenever possible!
| Prod ![Demand]
-- ^ @Prod ds@ describes the evaluation context of a case scrutinisation
-- on an expression of product type, where the product components are
@@ -306,7 +308,7 @@ polyDmd C_1N = C_1N :* poly1N
polyDmd C_10 = C_10 :* poly10
-- | A smart constructor for 'Prod', applying rewrite rules along the semantic
--- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
+-- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'
-- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a
-- polymorphic demand will never unbox.
mkProd :: [Demand] -> SubDemand
@@ -335,6 +337,13 @@ viewProd _ _ = Nothing
{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation
-- for Arity. Otherwise, #18304 bites us.
+-- | A smart constructor for 'Call', applying rewrite rules along the semantic
+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's
+-- when possible.
+mkCall :: Card -> SubDemand -> SubDemand
+mkCall n cd@(Poly m) | n == m = cd
+mkCall n cd = Call n cd
+
-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as
-- necessary.
viewCall :: SubDemand -> Maybe (Card, SubDemand)
@@ -356,8 +365,8 @@ lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
-- Handle Call
lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
-- See Note [Call demands are relative]
- | isAbs n2 = Call (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
- | otherwise = Call (lubCard n1 n2) (lubSubDmd d1 d2)
+ | isAbs n2 = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)
+ | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2)
-- Handle Poly
lubSubDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -377,8 +386,8 @@ plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =
-- Handle Call
plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))
-- See Note [Call demands are relative]
- | isAbs n2 = Call (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
- | otherwise = Call (plusCard n1 n2) (lubSubDmd d1 d2)
+ | isAbs n2 = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)
+ | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1 d2)
-- Handle Poly
plusSubDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2)
-- Make use of reflexivity (so we'll match the Prod or Call cases again).
@@ -407,7 +416,7 @@ multSubDmd :: Card -> SubDemand -> SubDemand
multSubDmd n sd
| Just sd' <- multTrivial n seqSubDmd sd = sd'
multSubDmd n (Poly n') = Poly (multCard n n')
-multSubDmd n (Call n' sd) = Call (multCard n n') sd -- See Note [Call demands are relative]
+multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]
multSubDmd n (Prod ds) = Prod (map (multDmd n) ds)
multDmd :: Card -> Demand -> Demand
@@ -457,22 +466,22 @@ evalDmd = C_1N :* topSubDmd
-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@.
-- Called exactly once.
strictOnceApply1Dmd :: Demand
-strictOnceApply1Dmd = C_11 :* Call C_11 topSubDmd
+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd
-- | First argument of 'GHC.Exts.atomically#': @MCM(U)@.
-- Called at least once, possibly many times.
strictManyApply1Dmd :: Demand
-strictManyApply1Dmd = C_1N :* Call C_1N topSubDmd
+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd
-- | First argument of catch#: @1C1(U)@.
-- Evaluates its arg lazily, but then applies it exactly once to one argument.
lazyApply1Dmd :: Demand
-lazyApply1Dmd = C_01 :* Call C_01 topSubDmd
+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd
-- | Second argument of catch#: @1C1(CS(U))@.
-- Calls its arg lazily, but then applies it exactly once to an additional argument.
lazyApply2Dmd :: Demand
-lazyApply2Dmd = C_01 :* Call C_01 (Call C_11 topSubDmd)
+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)
-- | Make a 'Demand' evaluated at-most-once.
oneifyDmd :: Demand -> Demand
@@ -503,7 +512,7 @@ strictifyDictDmd ty (n :* Prod ds)
-- type is a non-newtype dictionary type
as_non_newtype_dict ty
| Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)
- <- splitDataProductType_maybe ty
+ <- splitNonExDataProductType_maybe ty
, not (isNewTyCon tycon)
, isClassTyCon tycon
= Just inst_con_arg_tys
@@ -512,12 +521,12 @@ strictifyDictDmd ty (n :* Prod ds)
strictifyDictDmd _ dmd = dmd
-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @CS(d)@.
-mkCallDmd :: SubDemand -> SubDemand
-mkCallDmd sd = Call C_11 sd
+mkCalledOnceDmd :: SubDemand -> SubDemand
+mkCalledOnceDmd sd = mkCall C_11 sd
--- | @mkCallDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
-mkCallDmds :: Arity -> SubDemand -> SubDemand
-mkCallDmds arity sd = iterate mkCallDmd sd !! arity
+-- | @mkCalledOnceDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s.
+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand
+mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity
-- | Peels one call level from the sub-demand, and also returns how many
-- times we entered the lambda body.
@@ -669,7 +678,7 @@ This is needed even for non-product types, in case the case-binder
is used but the components of the case alternative are not.
Note [Don't optimise UP(U,U,...) to U]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
These two SubDemands:
UP(U,U) (@Prod [topDmd, topDmd]@) and U (@topSubDmd@)
are semantically equivalent, but we do not turn the former into
@@ -1184,6 +1193,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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1571,9 +1585,9 @@ This is weird, so I'm not worried about whether this optimises brilliantly; but
it should not fall over.
-}
-zapUsageEnvSig :: StrictSig -> StrictSig
--- Remove the usage environment from the demand
-zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
+-- | Remove the demand environment from the signature.
+zapDmdEnvSig :: StrictSig -> StrictSig
+zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r
zapUsageDemand :: Demand -> Demand
-- Remove the usage info, but not the strictness info, from the demand
@@ -1615,8 +1629,8 @@ kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd
kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
kill_usage_sd kfs (Call n sd)
- | kf_called_once kfs = Call (lubCard C_1N n) (kill_usage_sd kfs sd)
- | otherwise = Call n (kill_usage_sd kfs sd)
+ | kf_called_once kfs = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)
+ | otherwise = mkCall n (kill_usage_sd kfs sd)
kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)
kill_usage_sd _ sd = sd
@@ -1640,7 +1654,7 @@ trimToType (n :* sd) ts
where
go (Prod ds) (TsProd tss)
| equalLength ds tss = Prod (zipWith trimToType ds tss)
- go (Call n sd) (TsFun ts) = Call n (go sd ts)
+ go (Call n sd) (TsFun ts) = mkCall n (go sd ts)
go sd at Poly{} _ = sd
go _ _ = topSubDmd
@@ -1804,7 +1818,7 @@ instance Binary SubDemand where
h <- getByte bh
case h of
0 -> Poly <$> get bh
- 1 -> Call <$> get bh <*> get bh
+ 1 -> mkCall <$> get bh <*> get bh
2 -> Prod <$> get bh
_ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -650,7 +650,7 @@ zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
zapUsageEnvInfo :: IdInfo -> Maybe IdInfo
zapUsageEnvInfo info
| hasDemandEnvSig (strictnessInfo info)
- = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})
+ = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)})
| otherwise
= Nothing
=====================================
testsuite/tests/arityanal/should_compile/Arity11.stderr
=====================================
@@ -35,7 +35,7 @@ end Rec }
-- RHS size: {terms: 52, types: 28, coercions: 0, joins: 0/5}
F11.$wfib [InlPrag=[2]] :: forall {a} {p}. (a -> a -> Bool) -> (Num a, Num p) => a -> p
-[GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}]
+[GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}]
F11.$wfib
= \ (@a) (@p) (ww :: a -> a -> Bool) (w :: Num a) (w1 :: Num p) (w2 :: a) ->
let {
@@ -73,7 +73,7 @@ F11.$wfib
fib [InlPrag=[2]] :: forall {a} {p}. (Eq a, Num a, Num p) => a -> p
[GblId,
Arity=4,
- Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,UCU(U))><U>,
+ Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,U)><UP(UCU(CS(U)),A,A,A,A,A,U)><U>,
Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a) (@p) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num p) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww1 [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @p ww1 w1 w2 w3 }}]
fib = \ (@a) (@p) (w :: Eq a) (w1 :: Num a) (w2 :: Num p) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww1 ww2 -> F11.$wfib @a @p ww1 w1 w2 w3 }
=====================================
testsuite/tests/arityanal/should_compile/Arity16.stderr
=====================================
@@ -5,7 +5,7 @@ Result size of Tidy Core = {terms: 52, types: 87, coercions: 0, joins: 0/0}
Rec {
-- RHS size: {terms: 15, types: 17, coercions: 0, joins: 0/0}
map2 [Occ=LoopBreaker] :: forall {t} {a}. (t -> a) -> [t] -> [a]
-[GblId, Arity=2, Str=<UCU(U)><SU>, Unf=OtherCon []]
+[GblId, Arity=2, Str=<U><SU>, Unf=OtherCon []]
map2
= \ (@t) (@a) (f :: t -> a) (ds :: [t]) ->
case ds of {
=====================================
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/T18894.hs
=====================================
@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+-- | The point of this test is that @g*@ get's a demand that says
+-- "whenever @g*@ is called, the second component of the pair is evaluated strictly".
+module T18894 (h1, h2) where
+
+g1 :: Int -> (Int,Int)
+g1 1 = (15, 0)
+g1 n = (2 * n, 2 `div` n)
+{-# NOINLINE g1 #-}
+
+h1 :: Int -> Int
+h1 1 = 0
+-- Sadly, the @g1 2@ subexpression will be floated to top-level, where we
+-- don't see the specific demand placed on it by @snd at . Tracked in #19001.
+h1 2 = snd (g1 2)
+h1 m = uncurry (+) (g1 m)
+
+g2 :: Int -> Int -> (Int,Int)
+g2 m 1 = (m, 0)
+g2 m n = (2 * m, 2 `div` n)
+{-# NOINLINE g2 #-}
+
+h2 :: Int -> Int
+h2 1 = 0
+h2 m
+ | odd m = snd (g2 m 2)
+ | otherwise = uncurry (+) (g2 2 m)
=====================================
testsuite/tests/stranal/should_compile/T18894.stderr
=====================================
@@ -0,0 +1,404 @@
+
+==================== Demand analysis ====================
+Result size of Demand analysis
+ = {terms: 177, types: 97, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18894.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 36, types: 16, coercions: 0, joins: 0/0}
+g2 [InlPrag=NOINLINE, Dmd=UCU(CS(P(1P(U),SP(U))))]
+ :: Int -> Int -> (Int, Int)
+[LclId,
+ Arity=2,
+ Str=<UP(U)><SP(SU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 161 20}]
+g2
+ = \ (m [Dmd=UP(U)] :: Int) (ds [Dmd=SP(SU)] :: Int) ->
+ case ds of { GHC.Types.I# ds [Dmd=SU] ->
+ case ds of ds [Dmd=1U] {
+ __DEFAULT ->
+ (case m of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) },
+ case ds of wild {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> GHC.Types.I# -2#;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ });
+ 1# -> (m, lvl)
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 36, types: 19, coercions: 0, joins: 0/0}
+h2 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(MU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+h2
+ = \ (ds [Dmd=SP(MU)] :: Int) ->
+ case ds of wild [Dmd=UP(U)] { GHC.Types.I# ds [Dmd=MU] ->
+ case ds of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT ->
+ case g2 wild lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y };
+ 0# ->
+ case g2 lvl wild of { (x [Dmd=SP(U)], ds [Dmd=SP(U)]) ->
+ case x of { GHC.Types.I# x ->
+ case ds of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ }
+ };
+ 1# -> lvl
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 15#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = (lvl, lvl)
+
+-- RHS size: {terms: 30, types: 11, coercions: 0, joins: 0/0}
+g1 [InlPrag=NOINLINE, Dmd=UCU(P(UP(U),UP(U)))] :: Int -> (Int, Int)
+[LclId,
+ Arity=1,
+ Str=<SP(SU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 141 10}]
+g1
+ = \ (ds [Dmd=SP(SU)] :: Int) ->
+ case ds of { GHC.Types.I# ds [Dmd=SU] ->
+ case ds of ds {
+ __DEFAULT ->
+ (GHC.Types.I# (GHC.Prim.*# 2# ds),
+ case ds of wild {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> GHC.Types.I# -2#;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ });
+ 1# -> lvl
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
+lvl = g1 (GHC.Types.I# 2#)
+
+-- RHS size: {terms: 28, types: 18, coercions: 0, joins: 0/0}
+h1 :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(MU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 111 10}]
+h1
+ = \ (ds [Dmd=SP(MU)] :: Int) ->
+ case ds of wild [Dmd=1P(1U)] { GHC.Types.I# ds [Dmd=MU] ->
+ case ds of {
+ __DEFAULT ->
+ case g1 wild of { (x [Dmd=SP(U)], ds [Dmd=SP(U)]) ->
+ case x of { GHC.Types.I# x ->
+ case ds of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ };
+ 1# -> lvl;
+ 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y }
+ }
+ }
+
+
+
+
+==================== Demand analysis ====================
+Result size of Demand analysis
+ = {terms: 171, types: 120, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18894.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# -2#
+
+-- RHS size: {terms: 32, types: 18, coercions: 0, joins: 0/0}
+$wg2 [InlPrag=NOINLINE, Dmd=UCU(CS(P(1P(U),SP(U))))]
+ :: Int -> GHC.Prim.Int# -> (# Int, Int #)
+[LclId,
+ Arity=2,
+ Str=<UP(U)><SU>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 121 20}]
+$wg2
+ = \ (w [Dmd=UP(U)] :: Int) (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT ->
+ (# case w of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) },
+ case ds of {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> lvl;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ } #);
+ 1# -> (# w, lvl #)
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 34, types: 21, coercions: 0, joins: 0/0}
+$wh2 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
+[LclId,
+ Arity=1,
+ Str=<SU>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 162 10}]
+$wh2
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT ->
+ case $wg2 (GHC.Types.I# ds) 2# of
+ { (# ww [Dmd=A], ww [Dmd=SU] #) ->
+ ww
+ };
+ 0# ->
+ case $wg2 lvl ds of { (# ww [Dmd=SP(U)], ww [Dmd=SP(U)] #) ->
+ case ww of { GHC.Types.I# x ->
+ case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ }
+ };
+ 1# -> lvl
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h2 [InlPrag=[2]] :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(SU)>,
+ 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= \ (w [Occ=Once1!] :: Int) ->
+ case w of { GHC.Types.I# ww [Occ=Once1, Dmd=MU] -> $wh2 ww }}]
+h2
+ = \ (w [Dmd=SP(SU)] :: Int) ->
+ case w of { GHC.Types.I# ww [Dmd=SU] -> $wh2 ww }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 15#
+
+-- RHS size: {terms: 28, types: 15, coercions: 0, joins: 0/0}
+$wg1 [InlPrag=NOINLINE, Dmd=UCU(P(UP(U),UP(U)))]
+ :: GHC.Prim.Int# -> (# Int, Int #)
+[LclId,
+ Arity=1,
+ Str=<SU>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 111 20}]
+$wg1
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT ->
+ (# GHC.Types.I# (GHC.Prim.*# 2# ds),
+ case ds of {
+ __DEFAULT ->
+ case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT ->
+ GHC.Types.I# ww4
+ };
+ -1# -> lvl;
+ 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { }
+ } #);
+ 1# -> (# lvl, lvl #)
+ }
+
+-- RHS size: {terms: 7, types: 9, coercions: 0, joins: 0/0}
+lvl :: (Int, Int)
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}]
+lvl = case $wg1 2# of { (# ww, ww #) -> (ww, ww) }
+
+-- RHS size: {terms: 25, types: 18, coercions: 0, joins: 0/0}
+$wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
+[LclId,
+ Arity=1,
+ Str=<SU>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 101 10}]
+$wh1
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds [Dmd=1U] {
+ __DEFAULT ->
+ case $wg1 ds of { (# ww [Dmd=SP(U)], ww [Dmd=SP(U)] #) ->
+ case ww of { GHC.Types.I# x ->
+ case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) }
+ }
+ };
+ 1# -> lvl;
+ 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=SU]) -> y }
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+h1 [InlPrag=[2]] :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(SU)>,
+ 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= \ (w [Occ=Once1!] :: Int) ->
+ case w of { GHC.Types.I# ww [Occ=Once1, Dmd=MU] -> $wh1 ww }}]
+h1
+ = \ (w [Dmd=SP(SU)] :: Int) ->
+ case w of { GHC.Types.I# ww [Dmd=SU] -> $wh1 ww }
+
+
+
=====================================
testsuite/tests/stranal/should_compile/T18894b.hs
=====================================
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -O -fno-call-arity -fforce-recomp #-}
+
+module T18894 (f) where
+
+expensive :: Int -> (Int, Int)
+expensive n = (n+1, n+2)
+{-# NOINLINE expensive #-}
+
+-- arity 1 by itself, but not exported, thus can be eta-expanded based on usage
+eta :: Int -> Int -> Int
+eta x = if fst (expensive x) == 13
+ then \y -> x + y
+ else \y -> x * y
+{-# NOINLINE eta #-}
+
+f :: Int -> Int
+f 1 = 0
+f m
+ | odd m = eta m 2
+ | otherwise = eta 2 m
=====================================
testsuite/tests/stranal/should_compile/T18894b.stderr
=====================================
@@ -0,0 +1,187 @@
+
+==================== Demand analysis ====================
+Result size of Demand analysis = {terms: 83, types: 40, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18894.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 16, types: 7, coercions: 0, joins: 0/0}
+expensive [InlPrag=NOINLINE, Dmd=UCU(P(SP(SU),A))] :: Int -> (Int, Int)
+[LclId,
+ Arity=1,
+ Str=<UP(U)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [40] 52 10}]
+expensive
+ = \ (n [Dmd=UP(U)] :: Int) ->
+ (case n of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) }, case n of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 2#) })
+
+-- RHS size: {terms: 20, types: 11, coercions: 0, joins: 0/0}
+eta [InlPrag=NOINLINE, Dmd=UCU(CS(U))] :: Int -> Int -> Int
+[LclId,
+ Arity=1,
+ Str=<UP(U)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 140 120}]
+eta
+ = \ (x [Dmd=UP(U)] :: Int) ->
+ case expensive x of { (x [Dmd=SP(SU)], ds1 [Dmd=A]) ->
+ case x of { GHC.Types.I# x [Dmd=SU] ->
+ case x of {
+ __DEFAULT -> \ (y [Dmd=SP(U)] :: Int) -> GHC.Num.$fNumInt_$c* x y;
+ 13# -> \ (y [Dmd=SP(U)] :: Int) -> GHC.Num.$fNumInt_$c+ x y
+ }
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 21, types: 5, coercions: 0, joins: 0/0}
+f :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(MU)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 111 0}]
+f = \ (ds [Dmd=SP(MU)] :: Int) ->
+ case ds of wild [Dmd=UP(U)] { GHC.Types.I# ds [Dmd=MU] ->
+ case ds of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT -> eta wild lvl;
+ 0# -> eta lvl wild
+ };
+ 1# -> lvl
+ }
+ }
+
+
+
+
+==================== Demand analysis ====================
+Result size of Demand analysis = {terms: 85, types: 47, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T18894"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18894.$trModule :: GHC.Types.Module
+[LclIdX, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T18894.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 16, types: 9, coercions: 0, joins: 0/0}
+$wexpensive [InlPrag=NOINLINE, Dmd=UCU(P(SP(SU),A))] :: Int -> (# Int, Int #)
+[LclId,
+ Arity=1,
+ Str=<UP(U)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [40] 42 10}]
+$wexpensive
+ = \ (w [Dmd=UP(U)] :: Int) ->
+ (# case w of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) },
+ case w of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 2#) } #)
+
+-- RHS size: {terms: 19, types: 12, coercions: 0, joins: 0/0}
+eta [InlPrag=NOINLINE, Dmd=UCU(CS(U))] :: Int -> Int -> Int
+[LclId,
+ Arity=2,
+ Str=<MP(U)><SP(U)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 120 0}]
+eta
+ = \ (x [Dmd=MP(U)] :: Int) (eta [Dmd=SP(U), OS=OneShot] :: Int) ->
+ case $wexpensive x of { (# ww [Dmd=SP(SU)], ww [Dmd=A] #) ->
+ case ww of { GHC.Types.I# x [Dmd=SU] ->
+ case x of {
+ __DEFAULT -> GHC.Num.$fNumInt_$c* x eta;
+ 13# -> GHC.Num.$fNumInt_$c+ x eta
+ }
+ }
+ }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 2#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 20, types: 3, coercions: 0, joins: 0/0}
+$wf [InlPrag=[2]] :: GHC.Prim.Int# -> Int
+[LclId,
+ Arity=1,
+ Str=<SU>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 121 0}]
+$wf
+ = \ (ww [Dmd=SU] :: GHC.Prim.Int#) ->
+ case ww of ds {
+ __DEFAULT ->
+ case GHC.Prim.remInt# ds 2# of {
+ __DEFAULT -> eta (GHC.Types.I# ds) lvl;
+ 0# -> eta lvl (GHC.Types.I# ds)
+ };
+ 1# -> lvl
+ }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+f [InlPrag=[2]] :: Int -> Int
+[LclIdX,
+ Arity=1,
+ Str=<SP(SU)>,
+ 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= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww [Occ=Once1, Dmd=MU] -> $wf ww }}]
+f = \ (w [Dmd=SP(SU)] :: Int) -> case w of { GHC.Types.I# ww [Dmd=SU] -> $wf ww }
+
+
+
=====================================
testsuite/tests/stranal/should_compile/T18982.hs
=====================================
@@ -0,0 +1,33 @@
+{-# 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
+
+f :: Box Int -> Int
+f (Box n) = n + 1
+{-# NOINLINE f #-}
+
+g :: Ex Int -> Int
+g (Ex e n) = e `seq` n + 1
+{-# NOINLINE g #-}
+
+h :: GADT a -> Int
+h (GADT n) = n + 1
+{-# NOINLINE h #-}
+
+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
=====================================
@@ -58,3 +58,9 @@ test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl'])
# We care about the call demand on $wg
test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppress-uniques'])
+# We care about the call demand on $wg1 and $wg2
+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'])
=====================================
testsuite/tests/stranal/sigs/T5075.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
+T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>
@@ -13,6 +13,6 @@ T5075.loop:
==================== Strictness signatures ====================
T5075.$trModule:
-T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U>
+T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,U)><U>
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aff39a6a7bb75e72dd5f94440789e87a3ac5715c...0f32bf5e434a4d33013cdc0b519e008b4be62602
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/aff39a6a7bb75e72dd5f94440789e87a3ac5715c...0f32bf5e434a4d33013cdc0b519e008b4be62602
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/20201204/38b872c1/attachment-0001.html>
More information about the ghc-commits
mailing list