diff options
| -rw-r--r-- | compiler/GHC/StgToCmm.hs | 2 | ||||
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/CmmPipeline.hs | 2 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.hs | 2 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.hs | 7 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 100 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.hs | 7 |
7 files changed, 89 insertions, 36 deletions
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 23d6ceeaa6..96fa9e5cc1 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -71,7 +71,7 @@ codeGen dflags this_mod data_tycons ; cgref <- liftIO $ newIORef =<< initC ; let cg :: FCode () -> Stream IO CmmGroup () cg fcode = do - cmm <- liftIO . withTiming (return dflags) (text "STG -> Cmm") (`seq` ()) $ do + cmm <- liftIO . withTimingSilent (return dflags) (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 60814f8039..82abbb62bd 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -48,7 +48,7 @@ import Hoopl.Collections import GHC.Platform import Maybes import DynFlags -import ErrUtils (withTiming) +import ErrUtils (withTimingSilent) import Panic import UniqSupply import MonadUtils @@ -74,7 +74,8 @@ cmmToRawCmm dflags cmms ; let do_one :: UniqSupply -> [CmmDecl] -> IO (UniqSupply, [RawCmmDecl]) do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTiming (return dflags) (text "Cmm -> Raw Cmm") forceRes $ + withTimingSilent (return dflags) (text "Cmm -> Raw Cmm") + forceRes $ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of (b,uniqs') -> return (uniqs',b) ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 4ad93598aa..5ac3fddb3b 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -39,7 +39,7 @@ cmmPipeline -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTiming (return dflags) (text "Cmm pipeline") forceRes $ +cmmPipeline hsc_env srtInfo prog = withTimingSilent (return dflags) (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 16963dcb94..f501e0354b 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -399,7 +399,7 @@ loadInterface doc_str mod from -- Redo search for our local hole module loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from | otherwise - = withTiming getDynFlags (text "loading interface") (pure ()) $ + = withTimingSilent getDynFlags (text "loading interface") (pure ()) $ do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 839999a32c..4109e50c02 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -70,9 +70,10 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps then Stream.mapM do_lint cmm_stream else cmm_stream - do_lint cmm = withTiming (pure dflags) - (text "CmmLint"<+>brackets (ppr this_mod)) - (const ()) $ do + do_lint cmm = withTimingSilent + (pure dflags) + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do { case cmmLint dflags cmm of Just err -> do { log_action dflags dflags diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index d270533acd..ba94ec0c50 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -50,7 +50,7 @@ module ErrUtils ( errorMsg, warningMsg, fatalErrorMsg, fatalErrorMsg'', compilationProgressMsg, - showPass, withTiming, + showPass, withTiming, withTimingSilent, debugTraceMsg, ghcExit, prettyPrintGhcErrors, @@ -619,11 +619,15 @@ showPass dflags what = ifVerbose dflags 2 $ logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) +data PrintTimings = PrintTimings | DontPrintTimings + deriving (Eq, Show) + -- | Time a compilation phase. -- -- When timings are enabled (e.g. with the @-v2@ flag), the allocations -- and CPU time used by the phase will be reported to stderr. Consider --- a typical usage: @withTiming getDynFlags (text "simplify") force pass@. +-- a typical usage: +-- @withTiming getDynFlags (text "simplify") force PrintTimings pass@. -- When timings are enabled the following costs are included in the -- produced accounting, -- @@ -643,31 +647,62 @@ showPass dflags what -- -- See Note [withTiming] for more. withTiming :: MonadIO m - => m DynFlags -- ^ A means of getting a 'DynFlags' (often - -- 'getDynFlags' will work here) - -> SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed + => m DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed -> m a -withTiming getDFlags what force_result action +withTiming getDFlags what force action = + withTiming' getDFlags what force PrintTimings action + + +-- | Same as 'withTiming', but doesn't print timings in the +-- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). +-- +-- See Note [withTiming] for more. +withTimingSilent + :: MonadIO m + => m DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTimingSilent getDFlags what force action = + withTiming' getDFlags what force DontPrintTimings action + +-- | Worker for 'withTiming' and 'withTimingSilent'. +withTiming' :: MonadIO m + => m DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> PrintTimings -- ^ Whether to print the timings + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming' getDFlags what force_result prtimings action = do dflags <- getDFlags if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags - then do liftIO $ logInfo dflags (defaultUserStyle dflags) - $ text "***" <+> what <> colon - liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:started:" <+> what + then do whenPrintTimings $ + logInfo dflags (defaultUserStyle dflags) $ + text "***" <+> what <> colon + eventBegins dflags what alloc0 <- liftIO getAllocationCounter start <- liftIO getCPUTime !r <- action () <- pure $ force_result r - liftIO $ traceEventIO $ showSDocOneLine dflags $ text "GHC:finished:" <+> what + eventEnds dflags what end <- liftIO getCPUTime alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down let alloc = alloc0 - alloc1 time = realToFrac (end - start) * 1e-9 - when (verbosity dflags >= 2) + when (verbosity dflags >= 2 && prtimings == PrintTimings) $ liftIO $ logInfo dflags (defaultUserStyle dflags) (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time @@ -677,15 +712,27 @@ withTiming getDFlags what force_result action <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) <+> text "megabytes") - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings "" - $ text $ showSDocOneLine dflags - $ hsep [ what <> colon - , text "alloc=" <> ppr alloc - , text "time=" <> doublePrec 3 time - ] + whenPrintTimings $ + dumpIfSet_dyn dflags Opt_D_dump_timings "" + $ text $ showSDocOneLine dflags + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] pure r else action + where whenPrintTimings = liftIO . when (prtimings == PrintTimings) + eventBegins dflags w = do + whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w) + liftIO $ traceEventIO (eventEndsDoc dflags w) + eventEnds dflags w = do + whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w) + liftIO $ traceEventIO (eventEndsDoc dflags w) + + eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w + eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w + debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val $ logInfo dflags (defaultDumpStyle dflags) msg @@ -759,15 +806,18 @@ For reference: withTiming :: MonadIO - => m DynFlags -- how to get the DynFlags - -> SDoc -- label for the computation we're timing - -> (a -> ()) -- how to evaluate the result - -> m a -- computation we're timing + => m DynFlags -- how to get the DynFlags + -> SDoc -- label for the computation we're timing + -> (a -> ()) -- how to evaluate the result + -> PrintTimings -- whether to report the timings when passed + -- -v2 or -ddump-timings + -> m a -- computation we're timing -> m a withTiming lets you run an action while: -(1) measuring the CPU time it took and reporting that on stderr, +(1) measuring the CPU time it took and reporting that on stderr + (when PrintTimings is passed), (2) emitting start/stop events to GHC's event log, with the label given as an argument. diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index f6ccc08aee..e033a4c218 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -334,7 +334,7 @@ finishNativeGen :: Instruction instr -> NativeGenAcc statics instr -> IO UniqSupply finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs - = withTiming (return dflags) (text "NCG") (`seq` ()) $ do + = withTimingSilent (return dflags) (text "NCG") (`seq` ()) $ do -- Write debug data and finish let emitDw = debugLevel dflags > 0 us' <- if not emitDw then return us else do @@ -402,8 +402,9 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs a) Right (cmms, cmm_stream') -> do (us', ngs'') <- - withTiming (return dflags) - ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do + withTimingSilent + (return dflags) + ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information let debugFlag = debugLevel dflags > 0 !ndbgs | debugFlag = cmmDebugGen modLoc cmms |