[Git][ghc/ghc][wip/T18894] DmdAnal: Annotate top-level function bindings with demands (#18894)
Sebastian Graf
gitlab at gitlab.haskell.org
Wed Nov 25 16:45:35 UTC 2020
Sebastian Graf pushed to branch wip/T18894 at Glasgow Haskell Compiler / GHC
Commits:
2391fad6 by Sebastian Graf at 2020-11-25T17:37:02+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
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.
This 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.
We only track bindings of function type in order not to risk huge compile-time
regressions.
Fixes #18894.
- - - - -
7 changed files:
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Types/Demand.hs
- compiler/GHC/Types/Id/Info.hs
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -525,12 +525,11 @@ 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
+-- ^ This finds all locally-defined free Ids on the right hand side of a rule
-- and returns them as a non-deterministic set
ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet
-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
- = fvVarSet $ filterFV isLocalId $
- addBndrs bndrs $ exprs_fvs args
+ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
+ = fvVarSet $ filterFV isLocalId $ addBndrs bndrs $ expr_fvs rhs
{-
Note [Rule free var hack] (Not a hack any more)
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Core.Type
import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds )
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,42 @@ 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
+ go _ [] = (nopDmdType, [])
+ go env (b:bs) = case b of
+ NonRec id rhs
+ | (env', lazy_fvs, id', rhs') <- dmdAnalRhsLetDown TopLevel NonRecursive env topSubDmd id rhs
+ , (dmd_ty', bs') <- go env' bs
+ , let dmd_ty'' = add_exported_use env' dmd_ty' id' `addLazyFVs` lazy_fvs
+ , (!dmd_ty''', id_dmd) <- findBndrDmd env' False dmd_ty'' id'
+ , let id'' = annotate_id_dmd id' id_dmd
+ -> (dmd_ty''', NonRec id'' rhs' : bs')
+ Rec pairs
+ | (env', lazy_fvs, pairs') <- dmdFix TopLevel env topSubDmd pairs
+ , let ids' = map fst pairs'
+ , (dmd_ty', bs') <- go env' bs
+ , let dmd_ty'' = add_exported_uses env' dmd_ty' ids' `addLazyFVs` lazy_fvs
+ , (!dmd_ty''', id_dmds) <- findBndrsDmds env' dmd_ty'' ids'
+ , let pairs'' = zipWith (\(id', rhs') dmd -> (annotate_id_dmd id' dmd, rhs')) pairs' id_dmds
+ -> (dmd_ty''', Rec pairs'' : bs')
+
+ annotate_id_dmd id dmd
+ | isInterestingTopLevelFn id
+ = id `setIdDemandInfo` dmd
+ | otherwise
+ = id `setIdDemandInfo` topDmd
-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
+ add_exported_uses env = foldl' (add_exported_use env)
+ 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 = foldr (unionVarSet . ruleRhsFreeIds) emptyVarSet rules
{- Note [Stamp out space leaks in demand analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -320,9 +335,7 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
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
+ (env1, lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel NonRecursive env dmd id rhs
(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]
@@ -344,8 +357,8 @@ 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]
+ body_ty1 = addLazyFVs body_ty lazy_fv -- see Note [Lazy and unleashable free variables]
+ body_ty2 = deleteFVs body_ty1 (map fst pairs) -- TODO: We could annotate idDemandInfo here
in
body_ty2 `seq`
(body_ty2, Let (Rec pairs') body')
@@ -554,6 +567,16 @@ strict in |y|.
************************************************************************
-}
+-- | 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
+isInterestingTopLevelFn id =
+ typeArity (idType id) `lengthExceeds` 0
+
dmdTransform :: AnalEnv -- ^ The strictness environment
-> Id -- ^ The function
-> SubDemand -- ^ The demand on the function
@@ -582,9 +605,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
@@ -612,33 +639,36 @@ dmdTransform env var dmd
--
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalRhsLetDown
- :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive
+ :: 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
+dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
= -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
- (lazy_fv, sig, rhs')
+ (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
| otherwise
- -- NB: rhs_arity
- -- See Note [Demand signatures are computed for a threshold demand based on idArity]
- = mkRhsDmd env rhs_arity rhs
+ = mkCallDmds 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,8 +681,8 @@ 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
@@ -669,13 +699,6 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
= 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).
@@ -939,8 +962,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 +1011,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') = dmdAnalRhsLetDown 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 ]
=====================================
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/WorkWrap/Utils.hs
=====================================
@@ -1275,10 +1275,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
=====================================
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/Types/Demand.hs
=====================================
@@ -73,7 +73,7 @@ module GHC.Types.Demand (
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
-- * Zapping usage information
- zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig
+ zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig
) where
#include "HsVersions.h"
@@ -1571,9 +1571,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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2391fad6423e51219c958f964499db6171a7cb73
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2391fad6423e51219c958f964499db6171a7cb73
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/20201125/f993ca4a/attachment-0001.html>
More information about the ghc-commits
mailing list