Commit 014ed644 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

Compute demand signatures assuming idArity

This does four things:

1. Look at `idArity` instead of manifest lambdas to decide whether to use LetUp
2. Compute the strictness signature in LetDown assuming at least `idArity`
   incoming arguments
3. Remove the special case for trivial RHSs, which is subsumed by 2
4. Don't perform the W/W split when doing so would eta expand a binding.
   Otherwise we would eta expand PAPs, causing unnecessary churn in the
   Simplifier.

NoFib Results

--------------------------------------------------------------------------------
        Program         Allocs    Instrs
--------------------------------------------------------------------------------
 fannkuch-redux          +0.3%      0.0%
             gg          -0.0%     -0.1%
       maillist          +0.2%     +0.2%
        minimax           0.0%     +0.8%
         pretty           0.0%     -0.1%
        reptile          -0.0%     -1.2%
--------------------------------------------------------------------------------
            Min          -0.0%     -1.2%
            Max          +0.3%     +0.8%
 Geometric Mean          +0.0%     -0.0%
parent 1abb76ab
......@@ -22,7 +22,7 @@ module Demand (
DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,
nopDmdType, botDmdType, mkDmdType,
addDemand, removeDmdTyArgs,
addDemand, ensureArgs,
BothDmdArg, mkBothDmdArg, toBothDmdArg,
DmdEnv, emptyDmdEnv,
......@@ -34,7 +34,7 @@ module Demand (
vanillaCprProdRes, cprSumRes,
appIsBottom, isBottomingSig, pprIfaceStrictSig,
trimCPRInfo, returnsCPR_maybe,
StrictSig(..), mkStrictSig, mkClosedStrictSig,
StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,
nopSig, botSig, cprProdSig,
isTopSig, hasDemandEnvSig,
splitStrictSig, strictSigDmdEnv,
......@@ -47,10 +47,10 @@ module Demand (
deferAfterIO,
postProcessUnsat, postProcessDmdType,
splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd,
splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,
mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,
dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,
trimToType, TypeShape(..),
TypeShape(..), peelTsFuns, trimToType,
useCount, isUsedOnce, reuseEnv,
killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig,
......@@ -675,10 +675,15 @@ mkProdDmd dx
= JD { sd = mkSProd $ map getStrDmd dx
, ud = mkUProd $ map getUseDmd dx }
-- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@.
mkCallDmd :: CleanDemand -> CleanDemand
mkCallDmd (JD {sd = d, ud = u})
= JD { sd = mkSCall d, ud = mkUCall One u }
-- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.
mkCallDmds :: Arity -> CleanDemand -> CleanDemand
mkCallDmds arity cd = iterate mkCallDmd cd !! arity
-- See Note [Demand on the worker] in WorkWrap
mkWorkerDemand :: Int -> Demand
mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }
......@@ -804,6 +809,13 @@ instance Outputable TypeShape where
ppr (TsFun ts) = text "TsFun" <> parens (ppr ts)
ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)
-- | @peelTsFuns n ts@ tries to peel off @n@ 'TsFun' constructors from @ts@ and
-- returns 'Just' the wrapped 'TypeShape' on success, and 'Nothing' otherwise.
peelTsFuns :: Arity -> TypeShape -> Maybe TypeShape
peelTsFuns 0 ts = Just ts
peelTsFuns n (TsFun ts) = peelTsFuns (n-1) ts
peelTsFuns _ _ = Nothing
trimToType :: Demand -> TypeShape -> Demand
-- See Note [Trimming a demand to a type]
trimToType (JD { sd = ms, ud = mu }) ts
......@@ -1207,12 +1219,8 @@ mkDmdType fv ds res = DmdType fv ds res
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
-- Remove any demand on arguments. This is used in dmdAnalRhs on the body
removeDmdTyArgs :: DmdType -> DmdType
removeDmdTyArgs = ensureArgs 0
-- This makes sure we can use the demand type with n arguments,
-- It extends the argument list with the correct resTypeArgDmd
-- | This makes sure we can use the demand type with n arguments.
-- It extends the argument list with the correct resTypeArgDmd.
-- It also adjusts the DmdResult: Divergence survives additional arguments,
-- CPR information does not (and definite converge also would not).
ensureArgs :: Arity -> DmdType -> DmdType
......@@ -1567,8 +1575,56 @@ and <L,U(U,U)> on the second, then returning a constructor.
If this same function is applied to one arg, all we can say is that it
uses x with <L,U>, and its arg with demand <L,U>.
Note [Understanding DmdType and StrictSig]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Demand types are sound approximations of an expression's semantics relative to
the incoming demand we put the expression under. Consider the following
expression:
\x y -> x `seq` (y, 2*x)
Here is a table with demand types resulting from different incoming demands we
put that expression under. Note the monotonicity; a stronger incoming demand
yields a more precise demand type:
incoming demand | demand type
----------------------------------------------------
<S ,HU > | <L,U><L,U>{}
<C(C(S )),C1(C1(U ))> | <S,U><L,U>{}
<C(C(S(S,L))),C1(C1(U(1*U,A)))> | <S,1*HU><S,1*U>{}
Note that in the first example, the depth of the demand type was *higher* than
the arity of the incoming call demand due to the anonymous lambda.
The converse is also possible and happens when we unleash demand signatures.
In @f x y@, the incoming call demand on f has arity 2. But if all we have is a
demand signature with depth 1 for @f@ (which we can safely unleash, see below),
the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.
So: Demand types are elicited by putting an expression under an incoming (call)
demand, the arity of which can be lower or higher than the depth of the
resulting demand type.
In contrast, a demand signature summarises a function's semantics *without*
immediately specifying the incoming demand it was produced under. Despite StrSig
being a newtype wrapper around DmdType, it actually encodes two things:
* The threshold (i.e., minimum arity) to unleash the signature
* A demand type that is sound to unleash when the minimum arity requirement is
met.
Here comes the subtle part: The threshold is encoded in the wrapped demand
type's depth! So in mkStrictSigForArity we make sure to trim the list of
argument demands to the given threshold arity. Call sites will make sure that
this corresponds to the arity of the call demand that elicited the wrapped
demand type. See also Note [What are demand signatures?] in DmdAnal.
Besides trimming argument demands, mkStrictSigForArity will also trim CPR
information if necessary.
-}
-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe
-- to unleash. Better construct this through 'mkStrictSigForArity'.
-- See Note [Understanding DmdType and StrictSig]
newtype StrictSig = StrictSig DmdType
deriving( Eq )
......@@ -1580,34 +1636,43 @@ pprIfaceStrictSig :: StrictSig -> SDoc
pprIfaceStrictSig (StrictSig (DmdType _ dmds res))
= hcat (map ppr dmds) <> ppr res
mkStrictSig :: DmdType -> StrictSig
mkStrictSig dmd_ty = StrictSig dmd_ty
-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'
-- unleashable at that arity. See Note [Understanding DmdType and StrictSig]
mkStrictSigForArity :: Arity -> DmdType -> StrictSig
mkStrictSigForArity arity dmd_ty = StrictSig (ensureArgs arity dmd_ty)
mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig
mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res)
mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)
splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
increaseStrictSigArity :: Int -> StrictSig -> StrictSig
-- Add extra arguments to a strictness signature
-- ^ Add extra arguments to a strictness signature.
-- In contrast to 'etaExpandStrictSig', this /prepends/ additional argument
-- demands and leaves CPR info intact.
increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))
| isTopDmdType dmd_ty = sig
| arity_increase <= 0 = sig
| arity_increase == 0 = sig
| arity_increase < 0 = WARN( True, text "increaseStrictSigArity:"
<+> text "negative arity increase"
<+> ppr arity_increase )
nopSig
| otherwise = StrictSig (DmdType env dmds' res)
where
dmds' = replicate arity_increase topDmd ++ dmds
etaExpandStrictSig :: Arity -> StrictSig -> StrictSig
-- We are expanding (\x y. e) to (\x y z. e z)
-- Add exta demands to the /end/ of the arg demands if necessary
etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res))
| isTopDmdType dmd_ty = sig
| arity_increase <= 0 = sig
| otherwise = StrictSig (DmdType env dmds' res)
where
arity_increase = arity - length dmds
dmds' = dmds ++ replicate arity_increase topDmd
-- ^ We are expanding (\x y. e) to (\x y z. e z).
-- In contrast to 'increaseStrictSigArity', this /appends/ extra arg demands if
-- necessary, potentially destroying the signature's CPR property.
etaExpandStrictSig arity (StrictSig dmd_ty)
| arity < dmdTypeDepth dmd_ty
-- an arity decrease must zap the whole signature, because it was possibly
-- computed for a higher incoming call demand.
= nopSig
| otherwise
= StrictSig $ ensureArgs arity dmd_ty
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
......
......@@ -668,6 +668,7 @@ isBottomingId v
| isId v = isBottomingSig (idStrictness v)
| otherwise = False
-- | Accesses the 'Id''s 'strictnessInfo'.
idStrictness :: Id -> StrictSig
idStrictness id = strictnessInfo (idInfo id)
......
......@@ -237,22 +237,34 @@ pprIdDetails other = brackets (pp other)
-- too big.
data IdInfo
= IdInfo {
arityInfo :: !ArityInfo, -- ^ 'Id' arity
ruleInfo :: RuleInfo, -- ^ Specialisations of the 'Id's function which exist
-- See Note [Specialisations and RULES in IdInfo]
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program
strictnessInfo :: StrictSig, -- ^ A strictness signature
demandInfo :: Demand, -- ^ ID demand information
callArityInfo :: !ArityInfo, -- ^ How this is called.
-- n <=> all calls have at least n arguments
levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type?
arityInfo :: !ArityInfo,
-- ^ 'Id' arity, as computed by 'CoreArity'. Specifies how many
-- arguments this 'Id' has to be applied to before it doesn any
-- meaningful work.
ruleInfo :: RuleInfo,
-- ^ Specialisations of the 'Id's function which exist.
-- See Note [Specialisations and RULES in IdInfo]
unfoldingInfo :: Unfolding,
-- ^ The 'Id's unfolding
cafInfo :: CafInfo,
-- ^ 'Id' CAF info
oneShotInfo :: OneShotInfo,
-- ^ Info about a lambda-bound variable, if the 'Id' is one
inlinePragInfo :: InlinePragma,
-- ^ Any inline pragma atached to the 'Id'
occInfo :: OccInfo,
-- ^ How the 'Id' occurs in the program
strictnessInfo :: StrictSig,
-- ^ A strictness signature. Digests how a function uses its arguments
-- if applied to at least 'arityInfo' arguments.
demandInfo :: Demand,
-- ^ ID demand information
callArityInfo :: !ArityInfo,
-- ^ How this is called. This is the number of arguments to which a
-- binding can be eta-expanded without losing any sharing.
-- n <=> all calls have at least n arguments
levityInfo :: LevityInfo
-- ^ when applied, will this Id ever have a levity-polymorphic type?
}
-- Setters
......
......@@ -700,6 +700,8 @@ setIdNotExported id = ASSERT( isLocalId id )
************************************************************************
-}
-- | Is this a type-level (i.e., computationally irrelevant, thus erasable)
-- variable? Satisfies @isTyVar = not . isId@.
isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar
isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
......@@ -712,17 +714,21 @@ isTcTyVar _ = False
isTyCoVar :: Var -> Bool
isTyCoVar v = isTyVar v || isCoVar v
-- | Is this a value-level (i.e., computationally relevant) 'Id'entifier?
-- Satisfies @isId = not . isTyVar@.
isId :: Var -> Bool
isId (Id {}) = True
isId _ = False
-- | Is this a coercion variable?
-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.
isCoVar :: Var -> Bool
-- A coercion variable
isCoVar (Id { id_details = details }) = isCoVarDetails details
isCoVar _ = False
-- | Is this a term variable ('Id') that is /not/ a coercion variable?
-- Satisfies @'isId' v ==> 'isCoVar' v == not ('isNonCoVarId' v)@.
isNonCoVarId :: Var -> Bool
-- A term variable (Id) that is /not/ a coercion variable
isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details)
isNonCoVarId _ = False
......
......@@ -158,7 +158,7 @@ exprBotStrictness_maybe e
{-
Note [exprArity invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~
exprArity has the following invariant:
exprArity has the following invariants:
(1) If typeArity (exprType e) = n,
then manifestArity (etaExpand e n) = n
......
......@@ -570,15 +570,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
(addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
-- Only non-rule loop breakers inhibit inlining
-- Check whether arity and demand type are consistent (only if demand analysis
-- already happened)
--
-- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides]
-- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial.
-- ; let dmdTy = idStrictness binder
-- ; checkL (case dmdTy of
-- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
-- (mkArityMsg binder)
-- We used to check that the dmdTypeDepth of a demand signature never
-- exceeds idArity, but that is an unnecessary complication, see
-- Note [idArity varies independently of dmdTypeDepth] in DmdAnal
-- Check that the binder's arity is within the bounds imposed by
-- the type and the strictness signature. See Note [exprArity invariant]
......@@ -2565,20 +2559,6 @@ mkKindErrMsg tyvar arg_ty
hang (text "Arg type:")
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
{- Not needed now
mkArityMsg :: Id -> MsgDoc
mkArityMsg binder
= vcat [hsep [text "Demand type has",
ppr (dmdTypeDepth dmd_ty),
text "arguments, rhs has",
ppr (idArity binder),
text "arguments,",
ppr binder],
hsep [text "Binder's strictness signature:", ppr dmd_ty]
]
where (StrictSig dmd_ty) = idStrictness binder
-}
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
......
......@@ -1149,15 +1149,15 @@ certainlyWillInline dflags fn_info
-- INLINABLE functions come via this path
-- See Note [certainlyWillInline: INLINABLE]
do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })
| not (null args) -- See Note [certainlyWillInline: be careful of thunks]
| arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks]
, not (isBottomingSig (strictnessInfo fn_info))
-- Do not unconditionally inline a bottoming functions even if
-- it seems smallish. We've carefully lifted it out to top level,
-- so we don't want to re-inline it.
, let arity = length args
, size - (10 * (arity + 1)) <= ufUseThreshold dflags
, let unf_arity = length args
, size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags
= Just (fn_unf { uf_src = InlineStable
, uf_guidance = UnfWhen { ug_arity = arity
, uf_guidance = UnfWhen { ug_arity = unf_arity
, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = inlineBoringOk expr } })
-- Note the "unsaturatedOk". A function like f = \ab. a
......@@ -1175,6 +1175,17 @@ found that the WorkWrap phase thought that
y = case x of F# v -> F# (v +# v)
was certainlyWillInline, so the addition got duplicated.
Note that we check arityInfo instead of the arity of the unfolding to detect
this case. This is so that we don't accidentally fail to inline small partial
applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2
(say). Here there is no risk of work duplication, and the RHS is tiny, so
certainlyWillInline should return True. But `unf_arity` is zero! However f's
arity, gotten from `arityInfo fn_info`, is 1.
Failing to say that `f` will inline forces W/W to generate a potentially huge
worker for f that will immediately cancel with `g`'s wrapper anyway, causing
unnecessary churn in the Simplifier while arriving at the same result.
Note [certainlyWillInline: INLINABLE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
certainlyWillInline /must/ return Nothing for a large INLINABLE thing,
......
......@@ -21,7 +21,7 @@ module SimplMonad (
import GhcPrelude
import Var ( Var, isTyVar, mkLocalVar )
import Var ( Var, isId, mkLocalVar )
import Name ( mkSystemVarName )
import Id ( Id, mkSysLocalOrCoVar )
import IdInfo ( IdDetails(..), vanillaIdInfo, setArityInfo )
......@@ -187,7 +187,8 @@ newJoinId bndrs body_ty
= do { uniq <- getUniqueM
; let name = mkSystemVarName uniq (fsLit "$j")
join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes]
arity = length (filter (not . isTyVar) bndrs)
-- Note [idArity for join points] in SimplUtils
arity = length (filter isId bndrs)
join_arity = length bndrs
details = JoinId join_arity
id_info = vanillaIdInfo `setArityInfo` arity
......
......@@ -1508,7 +1508,7 @@ tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
-> SimplM (Arity, Bool, OutExpr)
-- See Note [Eta-expanding at let bindings]
-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
-- (a) rhs' has manifest arity
-- (a) rhs' has manifest arity n
-- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
tryEtaExpandRhs mode bndr rhs
| Just join_arity <- isJoinId_maybe bndr
......@@ -1517,6 +1517,7 @@ tryEtaExpandRhs mode bndr rhs
-- Note [Do not eta-expand join points]
-- But do return the correct arity and bottom-ness, because
-- these are used to set the bndr's IdInfo (#15517)
-- Note [idArity for join points]
| otherwise
= do { (new_arity, is_bot, new_rhs) <- try_expand
......@@ -1610,6 +1611,13 @@ CorePrep comes around, the code is very likely to look more like this:
$j2 = if n > 0 then $j1
else (...) eta
Note [idArity for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because of Note [Do not eta-expand join points] we have it that the idArity
of a join point is always (less than or) equal to the join arity.
Essentially, for join points we set `idArity $j = count isId join_lam_bndrs`.
It really can be less if there are type-level binders in join_lam_bndrs.
Note [Do not eta-expand PAPs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to have old_arity = manifestArity rhs, which meant that we
......
......@@ -206,7 +206,6 @@ dmdAnal' env dmd (App fun arg)
-- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
(res_ty `bothDmdType` arg_ty, App fun' arg')
-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
dmdAnal' env dmd (Lam var body)
| isTyVar var
= let
......@@ -286,10 +285,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
-- 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 rhs
, Nothing <- unpackTrivial rhs
-- dmdAnalRhsLetDown treats trivial right hand sides specially
-- so if we have a trival right hand side, fall through to that.
| useLetUp id
= (final_ty, Let (NonRec id' rhs') body')
where
(body_ty, body') = dmdAnal env dmd body
......@@ -582,25 +578,6 @@ environment, which effectively assigns them 'nopSig' (see "getStrictness")
-}
-- Trivial RHS
-- See Note [Demand analysis for trivial right-hand sides]
dmdAnalTrivialRhs ::
AnalEnv -> Id -> CoreExpr -> Var ->
(DmdEnv, Id, CoreExpr)
dmdAnalTrivialRhs env id rhs fn
= (fn_fv, set_idStrictness env id fn_str, rhs)
where
fn_str = getStrictness env fn
fn_fv | isLocalId fn = unitVarEnv fn topDmd
| otherwise = emptyDmdEnv
-- Note [Remember to demand the function itself]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- fn_fv: don't forget to produce a demand for fn itself
-- Lacking this caused #9128
-- The demand is very conservative (topDmd), but that doesn't
-- matter; trivial bindings are usually inlined, so it only
-- kicks in for top-level bindings and NOINLINE bindings
-- Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
-- dmdAnalRhsLetDown implements the Down variant:
......@@ -621,28 +598,23 @@ dmdAnalRhsLetDown :: TopLevelFlag
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
| Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides]
= dmdAnalTrivialRhs env id rhs fn
| otherwise
= (lazy_fv, id', mkLams bndrs' body')
= (lazy_fv, id', rhs')
where
(bndrs, body, body_dmd)
= case isJoinId_maybe id of
Just join_arity -- See Note [Demand analysis for join points]
| (bndrs, body) <- collectNBinders join_arity rhs
-> (bndrs, body, let_dmd)
Nothing | (bndrs, body) <- collectBinders rhs
-> (bndrs, body, mkBodyDmd env body)
env_body = foldl' extendSigsWithLam env bndrs
(body_ty, body') = dmdAnal env_body body_dmd body
body_ty' = removeDmdTyArgs body_ty -- zap possible deep CPR info
(DmdType rhs_fv rhs_dmds rhs_res, bndrs')
= annotateLamBndrs env (isDFunId id) body_ty' bndrs
sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
id' = set_idStrictness env id sig_ty
rhs_arity = idArity id
rhs_dmd
-- See Note [Demand analysis for join points]
-- See Note [idArity for join points] in SimplUtils
-- rhs_arity matches the join arity of the join point
| isJoinId id
= mkCallDmds 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
(DmdType rhs_fv rhs_dmds rhs_res, rhs')
= dmdAnal env rhs_dmd rhs
sig = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')
id' = set_idStrictness env id sig
-- See Note [NOINLINE and strictness]
......@@ -666,36 +638,63 @@ dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
|| not (isStrictDmd (idDemandInfo id) || ae_virgin env)
-- See Note [Optimistic CPR in the "virgin" case]
mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand
-- See Note [Product demands for function body]
mkBodyDmd env body
= case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
Nothing -> cleanEvalDmd
Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
unpackTrivial :: CoreExpr -> Maybe Id
-- Returns (Just v) if the arg is really equal to v, modulo
-- casts, type applications etc
-- See Note [Demand analysis for trivial right-hand sides]
unpackTrivial (Var v) = Just v
unpackTrivial (Cast e _) = unpackTrivial e
unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e
unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
unpackTrivial _ = Nothing
-- | If given the RHS of a let-binding, this 'useLetUp' determines
-- whether we should process the binding up (body before rhs) or
-- down (rhs before body).
-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
-- unleashing on the given function's @rhs@, by creating a call demand of
-- @rhs_arity@ with a body demand appropriate for possible product types.
-- See Note [Product demands for function body].
-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a
-- clean usage demand of @C1(C1(U(U,U)))@.
mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
mkRhsDmd env rhs_arity rhs =
case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of
Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))
_ -> mkCallDmds rhs_arity cleanEvalDmd
-- | If given the let-bound 'Id', 'useLetUp' determines whether we should
-- process the binding up (body before rhs) or down (rhs before body).
--
-- We use LetDown if there is a chance to get a useful strictness signature.
-- This is the case when there are manifest value lambdas or the binding is a
-- join point (hence always acts like a function, not a value).
useLetUp :: Var -> CoreExpr -> Bool
useLetUp f _ | isJoinId f = False
useLetUp f (Lam v e) | isTyVar v = useLetUp f e
useLetUp _ (Lam _ _) = False
useLetUp _ _ = True
-- We use LetDown if there is a chance to get a useful strictness signature to
-- unleash at call sites. LetDown is generally more precise than LetUp if we can
-- correctly guess how it will be used in the body, that is, for which incoming
-- demand the strictness signature should be computed, which allows us to
-- unleash higher-order demands on arguments at call sites. This is mostly the
-- case when
--
-- * The binding takes any arguments before performing meaningful work (cf.
-- 'idArity'), in which case we are interested to see how it uses them.
-- * The binding is a join point, hence acting like a function, not a value.
-- As a big plus, we know *precisely* how it will be used in the body; since
-- it's always tail-called, we can directly unleash the incoming demand of
-- the let binding on its RHS when computing a strictness signature. See
-- [Demand analysis for join points].
--
-- Thus, if the binding is not a join point and its arity is 0, we have a thunk
-- and use LetUp, implying that we have no usable demand signature available
-- when we analyse the let body.
--
-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free
-- vars at most once, regardless of how many times it was forced in the body.
-- This makes a real difference wrt. usage demands. The other reason is being
-- able to unleash a more precise product demand on its RHS once we know how the
-- thunk was used in the let body.
--
-- Characteristic examples, always assuming a single evaluation:
--
-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that
-- the expression uses @y@ at most once.
-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that
-- @b@ is absent.
-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that
-- the expression uses @y@ strictly, because we have @f@'s demand signature
-- available at the call site.
-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>
-- LetDown. Compared to LetUp, we find out that the expression uses @y@
-- strictly, because we can unleash @exit@'s signature at each call site.
-- * 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)
{- Note [Demand analysis for join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -728,22 +727,141 @@ let_dmd here).
Another win for join points! #13543.
Note [Demand signatures are computed for a threshold demand based on idArity]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We compute demand signatures assuming idArity incoming arguments to approximate
behavior for when we have a call site with at least that many arguments. idArity
is /at least/ the number of manifest lambdas, but might be higher for PAPs and