diff options
| -rw-r--r-- | compiler/stranal/DmdAnal.hs | 100 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/spec-inline.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/stranal/sigs/T12370.hs | 12 | ||||
| -rw-r--r-- | testsuite/tests/stranal/sigs/T12370.stderr | 14 | ||||
| -rw-r--r-- | testsuite/tests/stranal/sigs/all.T | 1 |
5 files changed, 107 insertions, 22 deletions
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index 53144fff10..c7f07675f2 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -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... diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 64bf015a26..732265a8f6 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -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 { diff --git a/testsuite/tests/stranal/sigs/T12370.hs b/testsuite/tests/stranal/sigs/T12370.hs new file mode 100644 index 0000000000..8eff4ae7fe --- /dev/null +++ b/testsuite/tests/stranal/sigs/T12370.hs @@ -0,0 +1,12 @@ +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 + diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr new file mode 100644 index 0000000000..f8cb839436 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T12370.stderr @@ -0,0 +1,14 @@ + +==================== 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 + + diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index d5689afece..f28cda7b89 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -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, ['']) |