HsToCore.Coverage: Purge DynFlagswip/coverage-config

Finishes what !7467 (closed) started.

Progress towards #17957

8 files changed, 78 insertions, 46 deletions

diff --git a/compiler/GHC/Driver/Config/HsToCore/Ticks.hs b/compiler/GHC/Driver/Config/HsToCore/Ticks.hs
new file mode 100644
index 0000000000..1f98a7e2eb
--- /dev/null
+++ b/compiler/GHC/Driver/Config/HsToCore/Ticks.hs
@@ -0,0 +1,28 @@
+module GHC.Driver.Config.HsToCore.Ticks
+  ( initTicksConfig
+  )
+where
+
+import GHC.Prelude
+
+import Data.Maybe (catMaybes)
+
+import GHC.Driver.Backend
+import GHC.Driver.Session
+import GHC.HsToCore.Ticks
+
+initTicksConfig :: DynFlags -> TicksConfig
+initTicksConfig dflags = TicksConfig
+  { ticks_passes       = coveragePasses dflags
+  , ticks_profAuto     = profAuto dflags
+  , ticks_countEntries = gopt Opt_ProfCountEntries dflags
+  }
+
+coveragePasses :: DynFlags -> [TickishType]
+coveragePasses dflags = catMaybes
+  [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags
+  , ifA HpcTicks $ gopt Opt_Hpc dflags
+  , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto
+  , ifA SourceNotes $ needSourceNotes dflags
+  ]
+  where ifA x cond = if cond then Just x else Nothing
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index e200bd46bb..af4301cce7 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -246,6 +246,7 @@ import GHC.Types.Error (DiagnosticReason(..))
 import GHC.Types.SrcLoc
 import GHC.Types.SafeHaskell
 import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )
+import GHC.Types.ProfAuto
 import qualified GHC.Types.FieldLabel as FieldLabel
 import GHC.Data.FastString
 import GHC.Utils.TmpFs
@@ -759,14 +760,6 @@ instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where
 class ContainsDynFlags t where
     extractDynFlags :: t -> DynFlags
 
-data ProfAuto
-  = NoProfAuto         -- ^ no SCC annotations added
-  | ProfAutoAll        -- ^ top-level and nested functions are annotated
-  | ProfAutoTop        -- ^ top-level functions annotated only
-  | ProfAutoExports    -- ^ exported functions annotated only
-  | ProfAutoCalls      -- ^ annotate call-sites
-  deriving (Eq,Enum)
-
 -----------------------------------------------------------------------------
 -- Accessessors from 'DynFlags'
 
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 706bb0613a..6fec5e6bfe 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -20,6 +20,7 @@ import GHC.Prelude
 
 import GHC.Driver.Session
 import GHC.Driver.Config
+import GHC.Driver.Config.HsToCore.Ticks
 import GHC.Driver.Config.HsToCore.Usage
 import GHC.Driver.Env
 import GHC.Driver.Backend
@@ -155,10 +156,8 @@ deSugar hsc_env
         ; (binds_cvr, m_tickInfo)
                          <- if not (isHsBootOrSig hsc_src)
                               then addTicksToBinds
-                                       (TicksConfig
-                                        { ticksConfig_logger = hsc_logger hsc_env
-                                        , ticksConfig_dynFlags = hsc_dflags hsc_env
-                                        })
+                                       (hsc_logger hsc_env)
+                                       (initTicksConfig (hsc_dflags hsc_env))
                                        mod mod_loc
                                        export_set (typeEnvTyCons type_env) binds
                               else return (binds, Nothing)
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index f78ed14e1e..860bf597bb 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -12,15 +12,13 @@
 module GHC.HsToCore.Ticks
   ( TicksConfig (..)
   , Tick (..)
+  , TickishType (..)
   , addTicksToBinds
   , isGoodSrcSpan'
   ) where
 
 import GHC.Prelude as Prelude
 
-import GHC.Driver.Session
-import GHC.Driver.Backend
-
 import GHC.Hs
 import GHC.Unit
 
@@ -32,6 +30,8 @@ import GHC.Data.FastString
 import GHC.Data.Bag
 import GHC.Data.SizedSeq
 
+import GHC.Driver.Flags (DumpFlag(..))
+
 import GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Monad
@@ -45,6 +45,7 @@ import GHC.Types.Name
 import GHC.Types.CostCentre
 import GHC.Types.CostCentre.State
 import GHC.Types.Tickish
+import GHC.Types.ProfAuto
 
 import Control.Monad
 import Data.List (isSuffixOf, intersperse)
@@ -65,10 +66,17 @@ import qualified Data.Set as Set
 -- | Configuration for compilation pass to add tick for instrumentation
 -- to binding sites.
 data TicksConfig = TicksConfig
-  { ticksConfig_logger   :: Logger
+  { ticks_passes       :: ![TickishType]
+  -- ^ What purposes do we need ticks for
+
+  , ticks_profAuto     :: !ProfAuto
+  -- ^ What kind of {-# SCC #-} to add automatically
 
-  -- FIXME: replace this with the specific fields of DynFlags we care about.
-  , ticksConfig_dynFlags :: DynFlags
+  , ticks_countEntries :: !Bool
+  -- ^ Whether to count the entries to functions
+  --
+  -- Requires extra synchronization which can vastly degrade
+  -- performance.
   }
 
 data Tick = Tick
@@ -80,7 +88,8 @@ data Tick = Tick
 
 
 addTicksToBinds
-        :: TicksConfig
+        :: Logger
+        -> TicksConfig
         -> Module
         -> ModLocation          -- ^ location of the current module
         -> NameSet              -- ^ Exported Ids.  When we call addTicksToBinds,
@@ -90,12 +99,9 @@ addTicksToBinds
         -> LHsBinds GhcTc
         -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))
 
-addTicksToBinds (TicksConfig
-                 { ticksConfig_logger = logger
-                 , ticksConfig_dynFlags = dflags
-                 })
+addTicksToBinds logger cfg
                 mod mod_loc exports tyCons binds
-  | let passes = coveragePasses dflags
+  | let passes = ticks_passes cfg
   , not (null passes)
   , Just orig_file <- ml_hs_file mod_loc = do
 
@@ -105,7 +111,7 @@ addTicksToBinds (TicksConfig
             let env = TTE
                       { fileName     = mkFastString orig_file2
                       , declPath     = []
-                      , tte_countEntries = gopt Opt_ProfCountEntries dflags
+                      , tte_countEntries = ticks_countEntries cfg
                       , exports      = exports
                       , inlines      = emptyVarSet
                       , inScope      = emptyVarSet
@@ -114,7 +120,7 @@ addTicksToBinds (TicksConfig
                                                              RealSrcSpan l _ -> Just l
                                                              UnhelpfulSpan _ -> Nothing)
                                                 tyCons
-                      , density      = mkDensity tickish dflags
+                      , density      = mkDensity tickish $ ticks_profAuto cfg
                       , this_mod     = mod
                       , tickishType  = tickish
                       }
@@ -158,13 +164,13 @@ data TickDensity
   | TickCallSites         -- ^ for stack tracing
   deriving Eq
 
-mkDensity :: TickishType -> DynFlags -> TickDensity
-mkDensity tickish dflags = case tickish of
+mkDensity :: TickishType -> ProfAuto -> TickDensity
+mkDensity tickish pa = case tickish of
   HpcTicks             -> TickForCoverage
   SourceNotes          -> TickForCoverage
   Breakpoints          -> TickForBreakPoints
   ProfNotes ->
-    case profAuto dflags of
+    case pa of
       ProfAutoAll      -> TickAllFunctions
       ProfAutoTop      -> TickTopFunctions
       ProfAutoExports  -> TickExportedFunctions
@@ -245,7 +251,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
 
   -- See Note [inline sccs]
   tickish <- tickishType `liftM` getEnv
-  if inline && tickish == ProfNotes then return (L pos funBind) else do
+  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
 
   (fvs, mg) <-
         getFreeVars $
@@ -272,6 +278,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
   let mbCons = maybe Prelude.id (:)
   return $ L pos $ funBind { fun_matches = mg
                            , fun_tick = tick `mbCons` fun_tick funBind }
+  }
 
    where
    -- a binding is a simple pattern binding if it is a funbind with
@@ -1001,20 +1008,6 @@ data TickishType
   | SourceNotes
   deriving (Eq)
 
-coveragePasses :: DynFlags -> [TickishType]
-coveragePasses dflags =
-    ifa (breakpointsEnabled dflags)          Breakpoints $
-    ifa (gopt Opt_Hpc dflags)                HpcTicks $
-    ifa (sccProfilingEnabled dflags &&
-         profAuto dflags /= NoProfAuto)      ProfNotes $
-    ifa (needSourceNotes dflags)          SourceNotes []
-  where ifa f x xs | f         = x:xs
-                   | otherwise = xs
-
--- | Should we produce 'Breakpoint' ticks?
-breakpointsEnabled :: DynFlags -> Bool
-breakpointsEnabled dflags = backendWantsBreakpointTicks (backend dflags)
-
 -- | Tickishs that only make sense when their source code location
 -- refers to the current file. This might not always be true due to
 -- LINE pragmas in the code - which would confuse at least HPC.
diff --git a/compiler/GHC/Types/ProfAuto.hs b/compiler/GHC/Types/ProfAuto.hs
new file mode 100644
index 0000000000..99521b5ccf
--- /dev/null
+++ b/compiler/GHC/Types/ProfAuto.hs
@@ -0,0 +1,15 @@
+module GHC.Types.ProfAuto
+  ( ProfAuto (..)
+  )
+where
+
+import GHC.Prelude
+
+-- | What kind of {-# SCC #-} to add automatically
+data ProfAuto
+  = NoProfAuto         -- ^ no SCC annotations added
+  | ProfAutoAll        -- ^ top-level and nested functions are annotated
+  | ProfAutoTop        -- ^ top-level functions annotated only
+  | ProfAutoExports    -- ^ exported functions annotated only
+  | ProfAutoCalls      -- ^ annotate call-sites
+  deriving (Eq,Enum)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index d7ca0b84c0..36c05ac38e 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -404,6 +404,7 @@ Library
         GHC.Driver.Config.Diagnostic
         GHC.Driver.Config.Finder
         GHC.Driver.Config.HsToCore
+        GHC.Driver.Config.HsToCore.Ticks
         GHC.Driver.Config.HsToCore.Usage
         GHC.Driver.Config.Logger
         GHC.Driver.Config.Parser
@@ -721,6 +722,7 @@ Library
         GHC.Types.Name.Shape
         GHC.Types.Name.Ppr
         GHC.Types.PkgQual
+        GHC.Types.ProfAuto
         GHC.Types.RepType
         GHC.Types.SafeHaskell
         GHC.Types.SourceError
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 1cacba20b2..491fccd11b 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -1,4 +1,4 @@
-Found 286 Language.Haskell.Syntax module dependencies
+Found 287 Language.Haskell.Syntax module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.PrimOps.Ids
@@ -208,6 +208,7 @@ GHC.Types.Name.Ppr
 GHC.Types.Name.Reader
 GHC.Types.Name.Set
 GHC.Types.PkgQual
+GHC.Types.ProfAuto
 GHC.Types.RepType
 GHC.Types.SafeHaskell
 GHC.Types.SourceError
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index d6690e7306..e338d85507 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -1,4 +1,4 @@
-Found 293 GHC.Parser module dependencies
+Found 294 GHC.Parser module dependencies
 GHC.Builtin.Names
 GHC.Builtin.PrimOps
 GHC.Builtin.PrimOps.Ids
@@ -215,6 +215,7 @@ GHC.Types.Name.Ppr
 GHC.Types.Name.Reader
 GHC.Types.Name.Set
 GHC.Types.PkgQual
+GHC.Types.ProfAuto
 GHC.Types.RepType
 GHC.Types.SafeHaskell
 GHC.Types.SourceError