Add optional fine grained logging to the build pipeline

The log gets written to a `dist-newstyle/cache/timing-log.txt` and
format is "Start time, action, duration in seconds". The output is
not sorted on start time because the log tuple is only written at
when the action is complete, so a fast action that starts after
a slow action might be written before the fast action.

Actions other than `build` could probably also be instrumented in
a similar way, but that is not part of this PR.

Example log line:

  2024/06/18 06:29:30 UTC: Downloading colour-2.3.6 took 0.815885883s

An example command to enable the timming log (disabled by default):

  cabal --enable-log-timing build all

cabal-install/cabal-install.cabal

@@ -194,6 +194,7 @@ library
  Distribution.Client.TargetProblem
  Distribution.Client.TargetSelector
  Distribution.Client.Targets
+ Distribution.Client.TimingLog
  Distribution.Client.Types
  Distribution.Client.Types.AllowNewer
  Distribution.Client.Types.BuildResults

cabal-install/src/Distribution/Client/CmdBuild.hs

@@ -15,8 +15,10 @@ module Distribution.Client.CmdBuild
 
 import Distribution.Client.Compat.Prelude
 import Prelude ()
-
 import Distribution.Client.CmdErrorMessages
+import Distribution.Client.DistDirLayout
+ ( distProjectCacheDirectory
+ )
 import Distribution.Client.ProjectFlags
  ( removeIgnoreProjectOption
  )
@@ -25,7 +27,11 @@ import Distribution.Client.TargetProblem
  ( TargetProblem (..)
  , TargetProblem'
  )
-
+import Distribution.Client.TimingLog
+ ( closeTimingLog
+ , initTimingLog
+ , timingLogBracket
+ )
 import qualified Data.Map as Map
 import Distribution.Client.Errors
 import Distribution.Client.NixStyleOptions
@@ -43,6 +49,7 @@ import Distribution.Client.Setup
  ( CommonSetupFlags (..)
  , ConfigFlags (..)
  , GlobalFlags
+ , globalLogTiming
  , yesNoOpt
  )
 import Distribution.Simple.Command
@@ -136,54 +143,57 @@ defaultBuildFlags =
 buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
 buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globalFlags =
  withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do
- -- TODO: This flags defaults business is ugly
- let onlyConfigure =
- fromFlag
- ( buildOnlyConfigure defaultBuildFlags
- <> buildOnlyConfigure buildFlags
- )
- targetAction
- | onlyConfigure = TargetActionConfigure
- | otherwise = TargetActionBuild
-
- baseCtx <- case targetCtx of
- ProjectContext -> return ctx
- GlobalContext -> return ctx
- ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
-
- buildCtx <-
- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
- -- Interpret the targets on the command line as build targets
- -- (as opposed to say repl or haddock targets).
- targets <-
- either (reportBuildTargetProblems verbosity) return $
- resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- let elaboratedPlan' =
- pruneInstallPlanToTargets
- targetAction
- targets
+ initTimingLog (fromFlag $ globalLogTiming globalFlags) (distProjectCacheDirectory $ distDirLayout ctx)
+ timingLogBracket "Top level buildAction" $ do
+ -- TODO: This flags defaults business is ugly
+ let onlyConfigure =
+ fromFlag
+ ( buildOnlyConfigure defaultBuildFlags
+ <> buildOnlyConfigure buildFlags
+ )
+ targetAction
+ | onlyConfigure = TargetActionConfigure
+ | otherwise = TargetActionBuild
+
+ baseCtx <- case targetCtx of
+ ProjectContext -> return ctx
+ GlobalContext -> return ctx
+ ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
+
+ buildCtx <-
+ runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
+ -- Interpret the targets on the command line as build targets
+ -- (as opposed to say repl or haddock targets).
+ targets <-
+ either (reportBuildTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
  elaboratedPlan
- elaboratedPlan'' <-
- if buildSettingOnlyDeps (buildSettings baseCtx)
- then
- either (reportCannotPruneDependencies verbosity) return $
- pruneInstallPlanToDependencies
- (Map.keysSet targets)
- elaboratedPlan'
- else return elaboratedPlan'
-
- return (elaboratedPlan'', targets)
-
- printPlan verbosity baseCtx buildCtx
-
- buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
- runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+ Nothing
+ targetSelectors
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ targetAction
+ targets
+ elaboratedPlan
+ elaboratedPlan'' <-
+ if buildSettingOnlyDeps (buildSettings baseCtx)
+ then
+ either (reportCannotPruneDependencies verbosity) return $
+ pruneInstallPlanToDependencies
+ (Map.keysSet targets)
+ elaboratedPlan'
+ else return elaboratedPlan'
+
+ return (elaboratedPlan'', targets)
+
+ printPlan verbosity baseCtx buildCtx
+
+ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
+ runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+ closeTimingLog
  where
  verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
 

cabal-install/src/Distribution/Client/FetchUtils.hs

@@ -52,6 +52,9 @@ import Distribution.Client.Types
 import Distribution.Client.GlobalFlags
  ( RepoContext (..)
  )
+import Distribution.Client.TimingLog
+ ( timingLogBracket
+ )
 import Distribution.Client.Utils
  ( ProgressPhase (..)
  , progressMessage
@@ -259,11 +262,12 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do
  then do
  info verbosity $ prettyShow pkgid ++ " has already been downloaded."
  return (packageFile repo pkgid)
- else do
- progressMessage verbosity ProgressDownloading (prettyShow pkgid)
- res <- downloadRepoPackage
- progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
- return res
+ else
+ timingLogBracket ("Downloading " ++ prettyShow pkgid) $ do
+ progressMessage verbosity ProgressDownloading (prettyShow pkgid)
+ res <- downloadRepoPackage
+ progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
+ return res
  where
  -- whether we download or not is non-deterministic
  verbosity = verboseUnmarkOutput verbosity'

cabal-install/src/Distribution/Client/GlobalFlags.hs

@@ -89,6 +89,7 @@ data GlobalFlags = GlobalFlags
  , globalLocalNoIndexRepos :: NubList LocalRepo
  , globalActiveRepos :: Flag ActiveRepos
  , globalLogsDir :: Flag FilePath
+ , globalLogTiming :: Flag Bool
  , globalIgnoreExpiry :: Flag Bool
  -- ^ Ignore security expiry dates
  , globalHttpTransport :: Flag String
@@ -112,6 +113,7 @@ defaultGlobalFlags =
  , globalLocalNoIndexRepos = mempty
  , globalActiveRepos = mempty
  , globalLogsDir = mempty
+ , globalLogTiming = Flag False
  , globalIgnoreExpiry = Flag False
  , globalHttpTransport = mempty
  , globalNix = Flag False

cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs

@@ -53,6 +53,7 @@ import Distribution.Client.Setup
 import Distribution.Client.SetupWrapper
 import Distribution.Client.SourceFiles
 import Distribution.Client.SrcDist (allPackageSourceFiles)
+import Distribution.Client.TimingLog (timingLogBracket)
 import qualified Distribution.Client.Tar as Tar
 import Distribution.Client.Types hiding
  ( BuildFailure (..)
@@ -186,59 +187,66 @@ buildAndRegisterUnpackedPackage
  delegate $
  PBConfigurePhase $
  annotateFailure mlogFile ConfigureFailed $
- setup configureCommand Cabal.configCommonFlags configureFlags configureArgs
+ timingLogBracket ("Configure " ++ unUnitId (installedUnitId rpkg)) $ 
+ setup configureCommand Cabal.configCommonFlags configureFlags configureArgs
 
  -- Build phase
  delegate $
  PBBuildPhase $
  annotateFailure mlogFile BuildFailed $ do
- setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs
+ timingLogBracket ("Build " ++ unUnitId (installedUnitId rpkg)) $ 
+ setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs
 
  -- Haddock phase
  whenHaddock $
  delegate $
  PBHaddockPhase $
  annotateFailure mlogFile HaddocksFailed $ do
- setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs
+ timingLogBracket ("Haddock " ++ unUnitId (installedUnitId rpkg)) $
+ setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs
 
  -- Install phase
  delegate $
  PBInstallPhase
  { runCopy = \destdir ->
  annotateFailure mlogFile InstallFailed $
- setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs
+ timingLogBracket ("InstallCopy " ++ unUnitId (installedUnitId rpkg)) $
+ setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs
  , runRegister = \pkgDBStack registerOpts ->
  annotateFailure mlogFile InstallFailed $ do
- -- We register ourselves rather than via Setup.hs. We need to
- -- grab and modify the InstalledPackageInfo. We decide what
- -- the installed package id is, not the build system.
- ipkg0 <- generateInstalledPackageInfo
- let ipkg = ipkg0{Installed.installedUnitId = uid}
- criticalSection registerLock $
- Cabal.registerPackage
- verbosity
- compiler
- progdb
- Nothing
- (coercePackageDBStack pkgDBStack)
- ipkg
- registerOpts
- return ipkg
+ timingLogBracket ("InstallRegister " ++ unUnitId (installedUnitId rpkg)) $ do
+ -- We register ourselves rather than via Setup.hs. We need to
+ -- grab and modify the InstalledPackageInfo. We decide what
+ -- the installed package id is, not the build system.
+ ipkg0 <- generateInstalledPackageInfo
+ let ipkg = ipkg0{Installed.installedUnitId = uid}
+ criticalSection registerLock $
+ Cabal.registerPackage
+ verbosity
+ compiler
+ progdb
+ Nothing
+ (coercePackageDBStack pkgDBStack)
+ ipkg
+ registerOpts
+ return ipkg
  }
 
  -- Test phase
  whenTest $
  delegate $
  PBTestPhase $
  annotateFailure mlogFile TestsFailed $
- setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs
+ timingLogBracket ("Test " ++ unUnitId (installedUnitId rpkg)) $ 
+ setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs
 
  -- Bench phase
  whenBench $
  delegate $
  PBBenchPhase $
  annotateFailure mlogFile BenchFailed $
- setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs
+ timingLogBracket ("Bench " ++ unUnitId (installedUnitId rpkg)) $ 
+ setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs
 
  -- Repl phase
  whenRepl $

cabal-install/src/Distribution/Client/ProjectPlanning.hs

@@ -125,6 +125,7 @@ import Distribution.Client.RebuildMonad
 import Distribution.Client.Setup hiding (cabalVersion, packageName)
 import Distribution.Client.SetupWrapper
 import Distribution.Client.Store
+import Distribution.Client.TimingLog (timingLogBracket)
 import Distribution.Client.Targets (userToPackageConstraint)
 import Distribution.Client.Types
 import Distribution.Client.Utils (concatMapM, incVersion)
@@ -707,17 +708,18 @@ rebuildInstallPlan
  liftIO $ do
  notice verbosity "Resolving dependencies..."
  planOrError <-
- foldProgress logMsg (pure . Left) (pure . Right) $
- planPackages
- verbosity
- compiler
- platform
- solverSettings
- (installedPackages <> installedPkgIndex)
- sourcePkgDb
- pkgConfigDB
- localPackages
- localPackagesEnabledStanzas
+ timingLogBracket "Creating build plan" $ 
+ foldProgress logMsg (pure . Left) (pure . Right) $
+ planPackages
+ verbosity
+ compiler
+ platform
+ solverSettings
+ (installedPackages <> installedPkgIndex)
+ sourcePkgDb
+ pkgConfigDB
+ localPackages
+ localPackagesEnabledStanzas
  case planOrError of
  Left msg -> do
  reportPlanningFailure projectConfig compiler platform localPackages

cabal-install/src/Distribution/Client/Setup.hs

@@ -489,6 +489,13 @@ globalCommand commands =
  globalConfigFile
  (\v flags -> flags{globalConfigFile = v})
  (reqArgFlag "FILE")
+ , option
+ []
+ ["enable-log-timing"]
+ "Enable logging of timing information (defaults to False)"
+ globalLogTiming
+ (\v flags -> flags{globalLogTiming = v})
+ falseArg
  , option
  []
  ["ignore-expiry"]