summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/Config/HsToCore/Ticks.hs28
-rw-r--r--compiler/GHC/Driver/Session.hs9
-rw-r--r--compiler/GHC/HsToCore.hs7
-rw-r--r--compiler/GHC/HsToCore/Ticks.hs57
-rw-r--r--compiler/GHC/Types/ProfAuto.hs15
-rw-r--r--compiler/ghc.cabal.in2
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout3
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout3
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
View Lorry Controller Status