DynFlags: refactor DmdAnal

Make demand analysis usable without having to provide DynFlags.

2 files changed, 57 insertions, 52 deletions

diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 53cd8a9a78..d3e3b7c87b 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -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.
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 64cb5e9486..3e9470dc88 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -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