driver: Add timing information to upsweep and some simple analysis scriptswip/par-stats

This comit adds a new flag `-ddump-make-stats` which
shows some statistics about the project build graph after compilation has finished.
These can be useful identifying bottlenecks in your projects module structure.

The statistics which are currently outputted are:

* The modules which took longest to compile.
* The modules which have the largest "flow". The initial flow is 1, and split
  evenly between all roots of the dependency graph. The flow is propagated
  through the graph, accumulated on each node and split evenly on children.
  The result is that any synchronisation points will have a flow equal to 1,
  and likewise other important modules will have a high flow value.
* The length of the longest (critical) path through the project. This provides
  a lower bound on the projects compilation time.
* The "parallelism score" which is the sum of compiling all nodes divided by
  the length of the critical path. This should be a more stable metric then
  critical path length because it doesn't depend on how fast your computer is.

For example, here is an example of the output from compiling the Cabal
library.

```
===== Maximum Duration (s) =====
000 M: main:Distribution.Simple.Setup (59): time: 1.40 allocs: 1489.93
001 M: main:Distribution.PackageDescription.Check (82): time: 0.68 allocs: 732.85
...
104 M: main:Distribution.Compat.GetShortPathName (9): time: 0.00 allocs: 3.62
105 M: main:Distribution.Compat.FilePath (8): time: 0.00 allocs: 3.46
===== Maximum Flows =====
000 M: main:Distribution.Simple (105): 1.000
001 M: main:Distribution.Simple.Configure (97): 0.346
...
104 M: main:Distribution.Simple.Program.Types (50): 0.002
105 M: main:Distribution.Simple.GHC.ImplInfo (46): 0.000
===== Flows x Time =====
000 M: main:Distribution.Simple (105): 0.175
001 M: main:Distribution.Simple.Configure (97): 0.127
...
104 M: main:Distribution.Backpack.PreExistingComponent (4): 0.000
105 M: main:Distribution.Simple.GHC.ImplInfo (46): 0.000
===== Statistics =====
longest path: 4.291s
parallelism score: 2.247
sequential time: 9.642s
```

In addition to this, the build graph is also emitted to the eventlog.
For each node in the build graph, an event is emitted to the eventlog of the form

```
node: { "node_id": 0, "node_deps": [0, 1,2,3], "node_desc": "GHC.Driver.Make" }
```

this allows external tooling to easily reconstruct the actual build
graph used by GHC and analyse it using external tools.

1 files changed, 71 insertions, 25 deletions

diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 8910dd4d38..a24120123d 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE RankNTypes      #-}
 {-# LANGUAGE ViewPatterns    #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
 
 {-
 (c) The AQUA Project, Glasgow University, 1994-1998
@@ -54,7 +55,8 @@ module GHC.Utils.Error (
         fatalErrorMsg,
         compilationProgressMsg,
         showPass,
-        withTiming, withTimingSilent,
+        TimingInfo(..), timingMillisecs,
+        withTiming, withTimingSilent, withTimingSilentX,
         debugTraceMsg,
         ghcExit,
         prettyPrintGhcErrors,
@@ -88,7 +90,8 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Catch as MC (handle)
 import GHC.Conc         ( getAllocationCounter )
-import System.CPUTime
+import Data.Int (Int64)
+import Data.Time (getCurrentTime, UTCTime, diffUTCTime)
 
 data DiagOpts = DiagOpts
   { diag_warning_flags       :: !(EnumSet WarningFlag) -- ^ Enabled warnings
@@ -305,6 +308,20 @@ showPass logger what =
 data PrintTimings = PrintTimings | DontPrintTimings
   deriving (Eq, Show)
 
+-- | The information collected by withTimings
+data TimingInfo = TimingInfo { timingPhase :: SDoc
+                             , timingStart, timingEnd :: UTCTime -- ^ The time in picoseconds
+                             , timingAllocs :: Int64}
+
+instance Outputable TimingInfo where
+  ppr t =
+    text "time:" <+> doublePrec 2 (timingMillisecs t)
+    <+> text "allocs:" <+>  doublePrec 2 (realToFrac (timingAllocs t) / 1024 / 1024)
+
+
+timingMillisecs :: TimingInfo -> Double
+timingMillisecs TimingInfo{..} = realToFrac (timingEnd `diffUTCTime` timingStart) -- / 1000
+
 -- | Time a compilation phase.
 --
 -- When timings are enabled (e.g. with the @-v2@ flag), the allocations
@@ -337,7 +354,7 @@ withTiming :: MonadIO m
            -> m a          -- ^ The body of the phase to be timed
            -> m a
 withTiming logger what force action =
-  withTiming' logger what force PrintTimings action
+  withTiming' logger Opt_D_dump_timings what force PrintTimings defaultTimingOutput action
 
 -- | Same as 'withTiming', but doesn't print timings in the
 --   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).
@@ -352,54 +369,83 @@ withTimingSilent
   -> m a        -- ^ The body of the phase to be timed
   -> m a
 withTimingSilent logger what force action =
-  withTiming' logger what force DontPrintTimings action
+  withTiming' logger Opt_D_dump_timings what force DontPrintTimings defaultTimingOutput action
+
+  -- | Same as 'withTimingSilent' but allows you to pass the continuation about how
+  -- to deal with the timing info at the end. This is used by the --make driver to
+  -- record how long it took to compile a module so we can do some analysis on the timings
+  -- after the build has completed.
+withTimingSilentX :: MonadIO m
+                  => Logger -> DumpFlag -> SDoc -> (a -> ())
+                  -> (TimingInfo -> m ()) -> m a -> m a
+withTimingSilentX logger flag what force k action =
+  withTiming' logger flag what force DontPrintTimings (\_ _ -> k) action
+
+defaultTimingOutput :: MonadIO f => Logger -> PrintTimings -> TimingInfo -> f ()
+defaultTimingOutput logger prtimings tinfo =
+  logTimingInfo logger prtimings tinfo
+  >> dumpTimingInfo logger prtimings tinfo
+
+
+
+logTimingInfo :: MonadIO f => Logger -> PrintTimings -> TimingInfo -> f ()
+logTimingInfo logger prtimings t@(TimingInfo {..}) = do
+    let time = timingMillisecs t
+    when (logVerbAtLeast logger 2 && prtimings == PrintTimings)
+                $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle
+                    (text "!!!" <+> timingPhase <> colon <+> text "finished in"
+                     <+> doublePrec 2 time
+                     <+> text "milliseconds"
+                     <> comma
+                     <+> text "allocated"
+                     <+> doublePrec 3 (realToFrac timingAllocs / 1024 / 1024)
+                     <+> text "megabytes")
+
+dumpTimingInfo :: MonadIO m => Logger -> PrintTimings -> TimingInfo -> m ()
+dumpTimingInfo logger prtimings t@(TimingInfo {..}) = do
+    let ctx = log_default_user_context (logFlags logger)
+    whenPrintTimings $
+      putDumpFileMaybe logger Opt_D_dump_timings "" FormatText
+          $ text $ showSDocOneLine ctx
+          $ hsep [ timingPhase <> colon
+                 , text "alloc=" <> ppr timingAllocs
+                 , text "time=" <> doublePrec 3 (timingMillisecs t)
+                 ]
+  where
+    whenPrintTimings = liftIO . when (prtimings == PrintTimings)
 
 -- | Worker for 'withTiming' and 'withTimingSilent'.
 withTiming' :: MonadIO m
             => Logger
+            -> DumpFlag
             -> SDoc         -- ^ The name of the phase
             -> (a -> ())    -- ^ A function to force the result
                             -- (often either @const ()@ or 'rnf')
             -> PrintTimings -- ^ Whether to print the timings
+            -> (Logger -> PrintTimings -> TimingInfo -> m ()) -- ^ What to do with all the information after it is collected
             -> m a          -- ^ The body of the phase to be timed
             -> m a
-withTiming' logger what force_result prtimings action
-  = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings
+withTiming' logger flag what force_result prtimings output_info action
+  = if logVerbAtLeast logger 2 || logHasDumpFlag logger flag
     then do whenPrintTimings $
               logInfo logger $ withPprStyle defaultUserStyle $
                 text "***" <+> what <> colon
             let ctx = log_default_user_context (logFlags logger)
             alloc0 <- liftIO getAllocationCounter
-            start <- liftIO getCPUTime
+            start <- liftIO getCurrentTime
             eventBegins ctx what
             recordAllocs alloc0
             !r <- action
             () <- pure $ force_result r
             eventEnds ctx what
-            end <- liftIO getCPUTime
+            end <- liftIO getCurrentTime
             alloc1 <- liftIO getAllocationCounter
             recordAllocs alloc1
             -- recall that allocation counter counts down
             let alloc = alloc0 - alloc1
-                time = realToFrac (end - start) * 1e-9
 
-            when (logVerbAtLeast logger 2 && prtimings == PrintTimings)
-                $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle
-                    (text "!!!" <+> what <> colon <+> text "finished in"
-                     <+> doublePrec 2 time
-                     <+> text "milliseconds"
-                     <> comma
-                     <+> text "allocated"
-                     <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)
-                     <+> text "megabytes")
+            output_info logger prtimings (TimingInfo what start end alloc)
 
-            whenPrintTimings $
-                putDumpFileMaybe logger Opt_D_dump_timings "" FormatText
-                    $ text $ showSDocOneLine ctx
-                    $ hsep [ what <> colon
-                           , text "alloc=" <> ppr alloc
-                           , text "time=" <> doublePrec 3 time
-                           ]
             pure r
      else action