Commit 9bbc84d2 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

DynFlags: refactor DmdAnal

Make demand analysis usable without having to provide DynFlags.
parent 990ea991
Pipeline #26188 passed with stages
in 289 minutes and 10 seconds
......@@ -9,18 +9,20 @@
{-# LANGUAGE CPP #-}
module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where
module GHC.Core.Opt.DmdAnal
( DmdAnalOpts(..)
, dmdAnalProgram
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Types.Demand -- All of it
import GHC.Core
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Core.Seq ( seqBinds )
import GHC.Utils.Outputable
import GHC.Types.Var.Env
import GHC.Types.Var.Set
......@@ -29,7 +31,6 @@ import Data.List ( mapAccumL )
import GHC.Core.DataCon
import GHC.Types.ForeignCall ( isSafeForeignCall )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.Utils
import GHC.Core.TyCon
import GHC.Core.Type
......@@ -41,7 +42,6 @@ import GHC.Utils.Panic
import GHC.Data.Maybe ( isJust )
import GHC.Builtin.PrimOps
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) )
import GHC.Types.Unique.Set
{-
......@@ -52,14 +52,21 @@ import GHC.Types.Unique.Set
************************************************************************
-}
dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnalProgram dflags fam_envs binds = do
let env = emptyAnalEnv dflags fam_envs
let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds
dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds
-- See Note [Stamp out space leaks in demand analysis]
seqBinds binds_plus_dmds `seq` return binds_plus_dmds
-- | Options for the demand analysis
data DmdAnalOpts = DmdAnalOpts
{ dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries
}
-- | Outputs a new copy of the Core program in which binders have been annotated
-- with demand and strictness information.
--
-- 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
......@@ -1235,31 +1242,13 @@ type DFunFlag = Bool -- indicates if the lambda being considered is in the
notArgOfDfun :: DFunFlag
notArgOfDfun = False
{- Note [dmdAnalEnv performance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's tempting to think that removing the dynflags from AnalEnv would improve
performance. After all when analysing recursive groups we end up allocating
a lot of environments. However this is not the case.
We do get some performance by making AnalEnv smaller. However very often we
defer computation which means we have to capture the dynflags in the thunks
we allocate. Doing this naively in practice causes more allocation than the
removal of DynFlags saves us.
In theory it should be possible to make this better if we are stricter in
the analysis and therefore allocate fewer thunks. But I couldn't get there
in a few hours and overall the impact on GHC here is small, and there are
bigger fish to fry. So for new the env will keep a reference to the flags.
-}
data AnalEnv
= AE { ae_dflags :: DynFlags -- See Note [dmdAnalEnv performance]
, ae_sigs :: SigEnv
, ae_virgin :: Bool -- True on first iteration only
data AnalEnv = AE
{ ae_strict_dicts :: !Bool -- ^ Enable strict dict
, ae_sigs :: !SigEnv
, ae_virgin :: !Bool -- ^ True on first iteration only
-- See Note [Initialising strictness]
, ae_fam_envs :: FamInstEnvs
}
, ae_fam_envs :: !FamInstEnvs
}
-- We use the se_env to tell us whether to
-- record info about a variable in the DmdEnv
......@@ -1271,17 +1260,18 @@ data AnalEnv
type SigEnv = VarEnv (StrictSig, TopLevelFlag)
instance Outputable AnalEnv where
ppr (AE { ae_sigs = env, ae_virgin = virgin })
= text "AE" <+> braces (vcat
[ text "ae_virgin =" <+> ppr virgin
, text "ae_sigs =" <+> ppr env ])
emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
emptyAnalEnv dflags fam_envs
= AE { ae_dflags = dflags
, ae_sigs = emptySigEnv
, ae_virgin = True
, ae_fam_envs = fam_envs
ppr env = text "AE" <+> braces (vcat
[ text "ae_virgin =" <+> ppr (ae_virgin env)
, text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env)
, text "ae_sigs =" <+> ppr (ae_sigs env)
])
emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
emptyAnalEnv opts fam_envs
= AE { ae_strict_dicts = dmd_strict_dicts opts
, ae_sigs = emptySigEnv
, ae_virgin = True
, ae_fam_envs = fam_envs
}
emptySigEnv :: SigEnv
......@@ -1334,7 +1324,7 @@ findBndrDmd env arg_of_dfun dmd_ty id
id_ty = idType id
strictify dmd
| gopt Opt_DictsStrict (ae_dflags env)
| ae_strict_dicts env
-- We never want to strictify a recursive let. At the moment
-- annotateBndr is only call for non-recursive lets; if that
-- changes, we need a RecFlag parameter and another guard here.
......
......@@ -24,7 +24,7 @@ import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import GHC.Types.Id.Info
import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )
import GHC.Core.Utils ( mkTicks, stripTicksTop )
import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult,
lintAnnots )
import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules )
......@@ -41,15 +41,17 @@ import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) )
import GHC.Types.Basic
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Demand
import GHC.Core.Opt.LiberateCase ( liberateCase )
import GHC.Core.Opt.StaticArgs ( doStaticArgs )
import GHC.Core.Opt.Specialise ( specProgram)
import GHC.Core.Opt.SpecConstr ( specConstrProgram)
import GHC.Core.Opt.DmdAnal ( dmdAnalProgram )
import GHC.Core.Opt.DmdAnal
import GHC.Core.Opt.CprAnal ( cprAnalProgram )
import GHC.Core.Opt.CallArity ( callArityAnalProgram )
import GHC.Core.Opt.Exitify ( exitifyProgram )
import GHC.Core.Opt.WorkWrap ( wwTopBinds )
import GHC.Core.Seq (seqBinds)
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Unit.Module.Env
......@@ -484,7 +486,7 @@ doCorePass CoreDoExitify = {-# SCC "Exitify" #-}
doPass exitifyProgram
doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-}
doPassDFM dmdAnalProgram
doPassDFM dmdAnal
doCorePass CoreDoCpr = {-# SCC "CprAnal" #-}
doPassDFM cprAnalProgram
......@@ -1074,3 +1076,16 @@ transferIdInfo exported_id local_id
(ruleInfo local_info)
-- Remember to set the function-name field of the
-- rules as we transfer them from one function to another
dmdAnal :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
dmdAnal dflags fam_envs binds = do
let opts = DmdAnalOpts
{ dmd_strict_dicts = gopt Opt_DictsStrict dflags
}
binds_plus_dmds = dmdAnalProgram opts fam_envs binds
Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
dumpIdInfoOfProgram (pprIfaceStrictSig . 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
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