Commit 45d8f4eb authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Demand analyser: Implement LetUp rule (#12370)

This makes the implementation match the description in the paper more
closely: There, a let binding that is not a function has first its body
analised, and then the binding’s RHS. This way, the demand on the bound
variable by the body can be fed into the RHS, yielding more precise
results.

Performance measurements do unfortunately not show significant
improvements or regessions.

Differential Revision: https://phabricator.haskell.org/D2395
parent 372dbc4e
......@@ -64,8 +64,8 @@ dmdAnalTopBind :: AnalEnv
dmdAnalTopBind sigs (NonRec id rhs)
= (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2)
where
( _, _, _, rhs1) = dmdAnalRhs TopLevel Nothing sigs id rhs
(sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1
( _, _, _, rhs1) = dmdAnalRhsLetDown TopLevel Nothing sigs id rhs
(sig, _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin sigs) id rhs1
-- Do two passes to improve CPR information
-- See comments with ignore_cpr_info in mk_sig_ty
-- and with extendSigsWithLam
......@@ -188,7 +188,7 @@ 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 @dmdAnalRhs@ uses @collectBinders@
-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
dmdAnal' env dmd (Lam var body)
| isTyVar var
= let
......@@ -255,10 +255,35 @@ 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 rhs
, Nothing <- unpackTrivial rhs
-- dmdAnalRhsLetDown treats trivial right hand sides specially
-- so if we have a trival right hand side, fall through to that.
= (final_ty, Let (NonRec id' rhs') 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' `bothDmdType` rhs_ty
dmdAnal' env dmd (Let (NonRec id rhs) body)
= (body_ty2, Let (NonRec id2 rhs') body')
where
(sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs
(sig, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env id rhs
(body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body
(body_ty1, id2) = annotateBndr env body_ty id1
body_ty2 = addLazyFVs body_ty1 lazy_fv
......@@ -509,7 +534,7 @@ dmdFix top_lvl env orig_pairs
my_downRhs (env, lazy_fv) (id,rhs)
= ((env', lazy_fv'), (id', rhs'))
where
(sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs
(sig, lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env id rhs
lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1
env' = extendAnalEnv top_lvl env id sig
......@@ -518,26 +543,47 @@ dmdFix top_lvl env orig_pairs
Just (sig,_) -> sig
Nothing -> pprPanic "dmdFix" (ppr var)
-- Non-recursive bindings
dmdAnalRhs :: TopLevelFlag
-- Trivial RHS
-- See Note [Demand analysis for trivial right-hand sides]
dmdAnalTrivialRhs ::
AnalEnv -> Id -> CoreExpr -> Var ->
(StrictSig, VarEnv Demand, Id, CoreExpr)
dmdAnalTrivialRhs env id rhs fn
= (fn_str, 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 Trac #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:
-- * assuming a demand of <L,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 :: TopLevelFlag
-> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
-> AnalEnv -> Id -> CoreExpr
-> (StrictSig, DmdEnv, Id, CoreExpr)
-> (StrictSig, 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.
dmdAnalRhs top_lvl rec_flag env id rhs
dmdAnalRhsLetDown top_lvl rec_flag env id rhs
| Just fn <- unpackTrivial rhs -- See Note [Demand analysis for trivial right-hand sides]
, let 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 Trac #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
= (fn_str, fn_fv, set_idStrictness env id fn_str, rhs)
= dmdAnalTrivialRhs env id rhs fn
| otherwise
= (sig_ty, lazy_fv, id', mkLams bndrs' body')
......@@ -587,6 +633,18 @@ 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).
--
-- We use LetDown if there is a chance to get a useful strictness signature.
-- This is the case when there are manifest value lambdas.
useLetUp :: CoreExpr -> Bool
useLetUp (Lam v e) | isTyVar v = useLetUp e
useLetUp (Lam _ _) = False
useLetUp _ = True
{-
Note [Demand analysis for trivial right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -659,7 +717,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 dmdAnalRhs. Roughly, it was
-- with the lazy_fv filtering in dmdAnalRhsLetDown. Roughly, it was
-- letrec f n x
-- = letrec g y = x `fatbar`
-- letrec h z = z + ...g...
......
......@@ -43,7 +43,7 @@ Rec {
-- RHS size: {terms: 55, types: 9, coercions: 0}
Roman.foo_$s$wgo [Occ=LoopBreaker]
:: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
[GblId, Arity=2, Caf=NoCafRefs, Str=<L,U><S,U>]
[GblId, Arity=2, Caf=NoCafRefs, Str=<S,U><S,U>]
Roman.foo_$s$wgo =
\ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
let {
......
module T12370 where
foo :: (Int, Int) -> Int
foo (x,y) = x + y
{-# NOINLINE foo #-}
-- If the p is processed by LetUp, then we get nice use-once demands on n and m
bar n m =
let p = (n,m)
{-# NOINLINE p #-}
in foo p
==================== Strictness signatures ====================
T12370.$trModule: m
T12370.bar: <S(S),1*U(U)><S(S),1*U(U)>m
T12370.foo: <S(S(S)S(S)),1*U(1*U(U),1*U(U))>m
==================== Strictness signatures ====================
T12370.$trModule: m
T12370.bar: <S(S),1*U(U)><S(S),1*U(U)>m
T12370.foo: <S(S(S)S(S)),1*U(1*U(U),1*U(U))>m
......@@ -15,3 +15,4 @@ test('FacState', expect_broken(1600), compile, [''])
test('UnsatFun', normal, compile, [''])
test('BottomFromInnerLambda', normal, compile, [''])
test('DmdAnalGADTs', normal, compile, [''])
test('T12370', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment