Useful cost centres, timers and allocation counters (#785)

* Add some useful cost-centres for profiling

* Add withTiming for each haddock phase

Invoking haddock with `--optghc=-ddump-timings` now shows the amount
of time spent and the number of allocated bytes for each phase.

2 files changed, 53 insertions, 27 deletions

diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index 23fefb3b..dc903e08 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wwarn #-}
-{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings, Rank2Types #-}
 {-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 -- |
@@ -238,8 +238,8 @@ renderStep dflags flags qual pkgs interfaces = do
       ((_, Just path), ifile) <- pkgs
       iface <- ifInstalledIfaces ifile
       return (instMod iface, path)
-  render dflags flags qual interfaces installedIfaces extSrcMap
 
+  render dflags flags qual interfaces installedIfaces extSrcMap
 
 -- | Render the interfaces with whatever backend is specified in the flags.
 render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> Map Module FilePath -> IO ()
@@ -323,24 +323,34 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
   let withQuickjump = Flag_QuickJumpIndex `elem` flags
 
   when (Flag_GenIndex `elem` flags) $ do
-    ppHtmlIndex odir title pkgStr
-                themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
-                allVisibleIfaces pretty
+    withTiming (pure dflags') "ppHtmlIndex" (const ()) $ do
+      _ <- {-# SCC ppHtmlIndex #-}
+           ppHtmlIndex odir title pkgStr
+                  themes opt_mathjax opt_contents_url sourceUrls' opt_wiki_urls
+                  allVisibleIfaces pretty
+      return ()
+
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_GenContents `elem` flags) $ do
-    ppHtmlContents dflags' odir title pkgStr
-                   themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
-                   allVisibleIfaces True prologue pretty
-                   (makeContentsQual qual)
+    withTiming (pure dflags') "ppHtmlContents" (const ()) $ do
+      _ <- {-# SCC ppHtmlContents #-}
+           ppHtmlContents dflags' odir title pkgStr
+                     themes opt_mathjax opt_index_url sourceUrls' opt_wiki_urls
+                     allVisibleIfaces True prologue pretty
+                     (makeContentsQual qual)
+      return ()
     copyHtmlBits odir libDir themes withQuickjump
 
   when (Flag_Html `elem` flags) $ do
-    ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
-                prologue
-                themes opt_mathjax sourceUrls' opt_wiki_urls
-                opt_contents_url opt_index_url unicode qual
-                pretty withQuickjump
+    withTiming (pure dflags') "ppHtml" (const ()) $ do
+      _ <- {-# SCC ppHtml #-}
+           ppHtml dflags' title pkgStr visibleIfaces reexportedIfaces odir
+                  prologue
+                  themes opt_mathjax sourceUrls' opt_wiki_urls
+                  opt_contents_url opt_index_url unicode qual
+                  pretty withQuickjump
+      return ()
     copyHtmlBits odir libDir themes withQuickjump
     writeHaddockMeta odir withQuickjump
 
@@ -359,15 +369,24 @@ render dflags flags qual ifaces installedIfaces extSrcMap = do
       Just (PackageName pkgNameFS, pkgVer) ->
           let pkgNameStr | unpackFS pkgNameFS == "main" && title /= [] = title
                          | otherwise = unpackFS pkgNameFS
-          in ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
-               visibleIfaces odir
+          in withTiming (pure dflags') "ppHoogle" (const ()) $ do
+               _ <- {-# SCC ppHoogle #-}
+                    ppHoogle dflags' pkgNameStr pkgVer title (fmap _doc prologue)
+                      visibleIfaces odir
+               return ()
 
   when (Flag_LaTeX `elem` flags) $ do
-    ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
-                  libDir
+    withTiming (pure dflags') "ppLatex" (const ()) $ do
+      _ <- {-# SCC ppLatex #-}
+           ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
+                   libDir
+      return ()
 
   when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
-    ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+    withTiming (pure dflags') "ppHyperlinkedSource" (const ()) $ do
+      _ <- {-# SCC ppHyperlinkedSource #-}
+           ppHyperlinkedSource odir libDir opt_source_css pretty srcMap ifaces
+      return ()
 
 -- | From GHC 7.10, this function has a potential to crash with a
 -- nasty message such as @expectJust getPackageDetails@ because
@@ -400,7 +419,7 @@ readInterfaceFiles :: MonadIO m
                    -> [(DocPaths, FilePath)]
                    -> m [(DocPaths, InterfaceFile)]
 readInterfaceFiles name_cache_accessor pairs = do
-  catMaybes `liftM` mapM tryReadIface pairs
+  catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs
   where
     -- try to read an interface, warn if we can't
     tryReadIface (paths, file) =
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index cbdf81cb..89064a6c 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface
@@ -60,6 +60,7 @@ import FastString (unpackFS)
 import MonadUtils (liftIO)
 import TcRnTypes (tcg_rdr_env)
 import RdrName (plusGlobalRdrEnv)
+import ErrUtils (withTiming)
 
 #if defined(mingw32_HOST_OS)
 import System.IO
@@ -93,13 +94,15 @@ processModules verbosity modules flags extIfaces = do
         filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces
       mods = Set.fromList $ map ifaceMod interfaces
   out verbosity verbose "Attaching instances..."
-  interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap
+  interfaces' <- {-# SCC attachInstances #-}
+                 withTiming getDynFlags "attachInstances" (const ()) $ do
+                   attachInstances (exportedNames, mods) interfaces instIfaceMap
 
   out verbosity verbose "Building cross-linking environment..."
   -- Combine the link envs of the external packages into one
   let extLinks  = Map.unions (map ifLinkEnv extIfaces)
-      homeLinks = buildHomeLinks interfaces -- Build the environment for the home
-                                            -- package
+      homeLinks = buildHomeLinks interfaces' -- Build the environment for the home
+                                             -- package
       links     = homeLinks `Map.union` extLinks
 
   out verbosity verbose "Renaming interfaces..."
@@ -155,7 +158,9 @@ createIfaces verbosity flags instIfaceMap mods = do
   return (reverse ifaces)
   where
     f (ifaces, ifaceMap) modSummary = do
-      x <- processModule verbosity modSummary flags ifaceMap instIfaceMap
+      x <- {-# SCC processModule #-}
+           withTiming getDynFlags "processModule" (const ()) $ do
+             processModule verbosity modSummary flags ifaceMap instIfaceMap
       return $ case x of
         Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
         Nothing    -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
@@ -164,7 +169,7 @@ createIfaces verbosity flags instIfaceMap mods = do
 processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
 processModule verbosity modsum flags modMap instIfaceMap = do
   out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
-  tm <- loadModule =<< typecheckModule =<< parseModule modsum
+  tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
 
   -- We need to modify the interactive context's environment so that when
   -- Haddock later looks for instances, it also looks in the modules it
@@ -179,7 +184,9 @@ processModule verbosity modsum flags modMap instIfaceMap = do
 
   if not $ isBootSummary modsum then do
     out verbosity verbose "Creating interface..."
-    (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap
+    (interface, msg) <- {-# SCC createIterface #-}
+                        withTiming getDynFlags "createInterface" (const ()) $ do
+                          runWriterGhc $ createInterface tm flags modMap instIfaceMap
     liftIO $ mapM_ putStrLn msg
     dflags <- getDynFlags
     let (haddockable, haddocked) = ifaceHaddockCoverage interface