Hadrian: trace the execution of expensive Cabal callswip/andrey/trace-cabal

We use Cabal to parse, configure, register and copy packages, which are
expensive operations that are currently not visible to Shake's profiling
infrastructure. By using `traced` we tell Shake to add these IO actions
to the profiling report, helping us to identify performance bottlenecks.

We use short tracing keys, as recommended in Shake docs: the name of the
current target is already available in the rest of the profiling
information.

1 files changed, 12 insertions, 8 deletions

diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
index d53aabd5e1..347aa99b15 100644
--- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
+++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs
@@ -55,7 +55,8 @@ import Settings
 -- "Hadrian.Oracles.TextFile.readPackageData" oracle.
 parsePackageData :: Package -> Action PackageData
 parsePackageData pkg = do
-    gpd <- liftIO $ C.readGenericPackageDescription C.verbose (pkgCabalFile pkg)
+    gpd <- traced "cabal-read" $
+        C.readGenericPackageDescription C.verbose (pkgCabalFile pkg)
     let pd      = C.packageDescription gpd
         pkgId   = C.package pd
         name    = C.unPackageName (C.pkgName pkgId)
@@ -141,8 +142,9 @@ configurePackage context@Context {..} = do
     argList     <- interpret (target context (Cabal Setup stage) [] []) flavourArgs
     verbosity   <- getVerbosity
     let v = if verbosity >= Loud then "-v3" else "-v0"
-    liftIO $ C.defaultMainWithHooksNoReadArgs hooks gpd
-        (argList ++ ["--flags=" ++ unwords flagList, v])
+    traced "cabal-configure" $
+        C.defaultMainWithHooksNoReadArgs hooks gpd
+            (argList ++ ["--flags=" ++ unwords flagList, v])
 
     dir <- Context.buildPath context
     files <- liftIO $ getDirectoryFilesIO "." [ dir -/- "include" <//> "*"
@@ -161,8 +163,9 @@ copyPackage context@Context {..} = do
     pkgDbPath <- packageDbPath stage
     verbosity <- getVerbosity
     let v = if verbosity >= Loud then "-v3" else "-v0"
-    liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
-        [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
+    traced "cabal-copy" $
+        C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
+            [ "copy", "--builddir", ctxPath, "--target-package-db", pkgDbPath, v ]
 
 -- | Register the 'Package' of a given 'Context' into the package database.
 registerPackage :: Context -> Action ()
@@ -172,8 +175,9 @@ registerPackage context@Context {..} = do
     gpd <- pkgGenericDescription package
     verbosity <- getVerbosity
     let v = if verbosity >= Loud then "-v3" else "-v0"
-    liftIO $ C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
-        [ "register", "--builddir", ctxPath, v ]
+    traced "cabal-register" $
+        C.defaultMainWithHooksNoReadArgs C.autoconfUserHooks gpd
+            [ "register", "--builddir", ctxPath, v ]
 
 -- | Parse the 'ContextData' of a given 'Context'.
 resolveContextData :: Context -> Action ContextData
@@ -293,7 +297,7 @@ buildAutogenFiles context = do
     pd <- packageDescription <$> readContextData context
     -- Note: the @cPath@ is ignored. The path that's used is the 'buildDir' path
     -- from the local build info @lbi@.
-    liftIO $ do
+    traced "cabal-autogen" $ do
         lbi <- C.getPersistBuildConfig cPath
         C.initialBuildSteps cPath pd (lbi { C.localPkgDescr = pd }) C.silent