diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2017-11-15 11:40:16 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-11-15 14:18:28 -0500 |
| commit | 383016b8ec3af3b0b1370e8966bba00397ddb848 (patch) | |
| tree | 909b54ffb7ce35b2cac68483d88b975ad708f2f4 | |
| parent | 1aba27a3c71b2a571f19d8a72c5918e165d26db5 (diff) | |
| download | haskell-383016b8ec3af3b0b1370e8966bba00397ddb848.tar.gz | |
Add dump flag for timing output
This allows you to use `-ddump-to-file -ddump-timings` for more useful
dump output.
Test Plan: Try it
Subscribers: rwbarton, thomie
Differential Revision: https://phabricator.haskell.org/D4195
| -rw-r--r-- | compiler/main/DynFlags.hs | 3 | ||||
| -rw-r--r-- | compiler/main/ErrUtils.hs | 27 |
2 files changed, 21 insertions, 9 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 53a4033db7..5888acc319 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -392,6 +392,7 @@ data DumpFlag | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles | Opt_D_dump_mod_map + | Opt_D_dump_timings | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug @@ -3081,6 +3082,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_mod_cycles) , make_ord_flag defGhcFlag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , make_ord_flag defGhcFlag "ddump-to-file" diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 258fc11709..1aa5238a89 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -614,7 +614,7 @@ withTiming :: MonadIO m -> m a withTiming getDFlags what force_result action = do dflags <- getDFlags - if verbosity dflags >= 2 + if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do liftIO $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon alloc0 <- liftIO getAllocationCounter @@ -625,14 +625,23 @@ withTiming getDFlags what force_result action alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down let alloc = alloc0 - alloc1 - liftIO $ logInfo dflags (defaultUserStyle dflags) - (text "!!!" <+> what <> colon <+> text "finished in" - <+> doublePrec 2 (realToFrac (end - start) * 1e-9) - <+> text "milliseconds" - <> comma - <+> text "allocated" - <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) - <+> text "megabytes") + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2) + $ liftIO $ logInfo dflags (defaultUserStyle dflags) + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings "" + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] pure r else action |