3e577a6dd3
Believed to be no longer needed as I've squashed the last ones. Note that, in Test.Framework, I can see no reason for the code to have run it twice. It does not cause running processes to exit after all, so any process that has leaked and is running and causing problems with cleanup of the directory won't be helped by running it. This commit was sponsored by Mark Reidenbach on Patreon.
48 lines
1.5 KiB
Haskell
48 lines
1.5 KiB
Haskell
{- git-annex benchmark infrastructure
|
|
-
|
|
- Copyright 2019 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Benchmark where
|
|
|
|
import Common
|
|
import Types.Benchmark
|
|
import Types.Command
|
|
import CmdLine.Action
|
|
import CmdLine
|
|
import CmdLine.GitAnnex.Options
|
|
import qualified Annex
|
|
import qualified Annex.Branch
|
|
|
|
import qualified Options.Applicative as O
|
|
|
|
{- Given a list of all git-annex Commands, and the user's input,
|
|
- generates an IO action to benchmark that runs the specified
|
|
- commands. -}
|
|
mkGenerator :: MkBenchmarkGenerator
|
|
mkGenerator cmds userinput = do
|
|
-- Get the git-annex branch updated, to avoid the overhead of doing
|
|
-- so skewing the runtime of the first action that will be
|
|
-- benchmarked.
|
|
Annex.Branch.commit "benchmarking"
|
|
_ <- Annex.Branch.update
|
|
l <- mapM parsesubcommand $ split [";"] userinput
|
|
return $ do
|
|
forM_ l $ \(cmd, seek, st) ->
|
|
-- The cmd is run for benchmarking without startup or
|
|
-- shutdown actions.
|
|
Annex.eval st $ performCommandAction cmd seek noop
|
|
where
|
|
-- Simplified versio of CmdLine.dispatch, without support for fuzzy
|
|
-- matching or out-of-repo commands.
|
|
parsesubcommand ps = do
|
|
(cmd, seek, globalconfig) <- liftIO $ O.handleParseResult $
|
|
parseCmd "git-annex" "benchmarking" gitAnnexGlobalOptions ps cmds cmdparser
|
|
-- Make an entirely separate Annex state for each subcommand,
|
|
-- and prepare it to run the cmd.
|
|
st <- liftIO . Annex.new =<< Annex.getState Annex.repo
|
|
((), st') <- liftIO $ Annex.run st $
|
|
prepRunCommand cmd globalconfig
|
|
return (cmd, seek, st')
|