From 77c42782d0bfa7e11db099dfd1ead400a8d3cb17 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 16 Sep 2020 11:41:28 -0400 Subject: [PATCH] differentiate between concurrency enabled at command line and by git config The latter should not affect --batch mode. --- Annex.hs | 4 ++-- Annex/Concurrent.hs | 29 +++++++++++++++++++---------- Annex/Concurrent/Utility.hs | 8 ++++++++ Annex/Ssh.hs | 5 +++-- Annex/Transfer.hs | 3 ++- CmdLine/Action.hs | 8 ++++---- CmdLine/GitAnnex/Options.hs | 2 +- Messages.hs | 3 ++- Types/Concurrency.hs | 5 +++++ 9 files changed, 46 insertions(+), 21 deletions(-) diff --git a/Annex.hs b/Annex.hs index 64ab9c0d74..13695c9986 100644 --- a/Annex.hs +++ b/Annex.hs @@ -112,7 +112,7 @@ data AnnexState = AnnexState , backend :: Maybe (BackendA Annex) , remotes :: [Types.Remote.RemoteA Annex] , output :: MessageState - , concurrency :: Concurrency + , concurrency :: ConcurrencySetting , force :: Bool , fast :: Bool , daemon :: Bool @@ -171,7 +171,7 @@ newState c r = do , backend = Nothing , remotes = [] , output = o - , concurrency = NonConcurrent + , concurrency = ConcurrencyCmdLine NonConcurrent , force = False , fast = False , daemon = False diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs index b4afaffc0a..856555bbe8 100644 --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -5,10 +5,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.Concurrent where +module Annex.Concurrent ( + module Annex.Concurrent, + module Annex.Concurrent.Utility +) where import Annex import Annex.Common +import Annex.Concurrent.Utility import qualified Annex.Queue import Annex.Action import Types.Concurrency @@ -22,19 +26,24 @@ import Control.Concurrent import Control.Concurrent.STM import qualified Data.Map as M -setConcurrency :: Concurrency -> Annex () -setConcurrency NonConcurrent = Annex.changeState $ \s -> s - { Annex.concurrency = NonConcurrent - } -setConcurrency c = do - cfh <- Annex.getState Annex.catfilehandles +setConcurrency :: ConcurrencySetting -> Annex () +setConcurrency (ConcurrencyCmdLine s) = setConcurrency' s ConcurrencyCmdLine +setConcurrency (ConcurrencyGitConfig s) = setConcurrency' s ConcurrencyGitConfig + +setConcurrency' :: Concurrency -> (Concurrency -> ConcurrencySetting) -> Annex () +setConcurrency' NonConcurrent f = + Annex.changeState $ \s -> s + { Annex.concurrency = f NonConcurrent + } +setConcurrency' c f = do + cfh <- getState Annex.catfilehandles cfh' <- case cfh of CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool CatFileHandlesPool _ -> pure cfh cah <- mkConcurrentCheckAttrHandle c cih <- mkConcurrentCheckIgnoreHandle c Annex.changeState $ \s -> s - { Annex.concurrency = c + { Annex.concurrency = f c , Annex.catfilehandles = cfh' , Annex.checkattrhandle = Just cah , Annex.checkignorehandle = Just cih @@ -74,9 +83,9 @@ dupState = do st <- Annex.getState id -- Make sure that concurrency is enabled, if it was not already, -- so the concurrency-safe resource pools are set up. - st' <- case Annex.concurrency st of + st' <- case getConcurrency' (Annex.concurrency st) of NonConcurrent -> do - setConcurrency (Concurrent 1) + setConcurrency (ConcurrencyCmdLine (Concurrent 1)) Annex.getState id _ -> return st return $ st' diff --git a/Annex/Concurrent/Utility.hs b/Annex/Concurrent/Utility.hs index 0521f6ba5d..2810f6da6b 100644 --- a/Annex/Concurrent/Utility.hs +++ b/Annex/Concurrent/Utility.hs @@ -7,10 +7,18 @@ module Annex.Concurrent.Utility where +import Annex import Types.Concurrency import GHC.Conc +getConcurrency :: Annex Concurrency +getConcurrency = getConcurrency' <$> getState concurrency + +getConcurrency' :: ConcurrencySetting -> Concurrency +getConcurrency' (ConcurrencyCmdLine c) = c +getConcurrency' (ConcurrencyGitConfig c) = c + {- Honor the requested level of concurrency, but only up to the number of - CPU cores. Useful for things that are known to be CPU bound. -} concurrencyUpToCpus :: Concurrency -> IO Int diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index f202add142..b19e54527e 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -34,6 +34,7 @@ import Annex.Path import Utility.Env import Utility.Hash import Types.CleanupActions +import Annex.Concurrent.Utility import Types.Concurrency import Git.Env import Git.Ssh @@ -107,7 +108,7 @@ sshCachingInfo (host, port) = go =<< sshCacheDir' -- No connection caching with concurrency is not a good -- combination, so warn the user. go (Left whynocaching) = do - Annex.getState Annex.concurrency >>= \case + getConcurrency >>= \case NonConcurrent -> return () Concurrent {} -> warnnocaching whynocaching ConcurrentPerCpu -> warnnocaching whynocaching @@ -229,7 +230,7 @@ prepSocket socketfile sshhost sshparams = do let socketlock = socket2lock socketfile - Annex.getState Annex.concurrency >>= \case + getConcurrency >>= \case NonConcurrent -> return () Concurrent {} -> makeconnection socketlock ConcurrentPerCpu -> makeconnection socketlock diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 3414431de1..f2321a7f36 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -31,6 +31,7 @@ import Annex.LockPool import Types.Key import qualified Types.Remote as Remote import Types.Concurrency +import Annex.Concurrent.Utility import Types.WorkerPool import Annex.WorkerPool import Backend (isCryptographicallySecure) @@ -262,7 +263,7 @@ configuredRetry numretries _old new = do - increase total transfer speed. -} pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v -pickRemote l a = debugLocks $ go l =<< Annex.getState Annex.concurrency +pickRemote l a = debugLocks $ go l =<< getConcurrency where go [] _ = return observeFailure go (r:[]) _ = a r diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs index a308488876..591c590b9a 100644 --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -53,7 +53,7 @@ commandActions = mapM_ commandAction - This should only be run in the seek stage. -} commandAction :: CommandStart -> Annex () -commandAction start = Annex.getState Annex.concurrency >>= \case +commandAction start = getConcurrency >>= \case NonConcurrent -> runnonconcurrent Concurrent _ -> runconcurrent ConcurrentPerCpu -> runconcurrent @@ -200,9 +200,9 @@ performCommandAction' startmsg perform = -} startConcurrency :: UsedStages -> Annex a -> Annex a startConcurrency usedstages a = do - fromcmdline <- Annex.getState Annex.concurrency + fromcmdline <- getConcurrency fromgitcfg <- annexJobs <$> Annex.getGitConfig - let usegitcfg = setConcurrency fromgitcfg + let usegitcfg = setConcurrency (ConcurrencyGitConfig fromgitcfg) case (fromcmdline, fromgitcfg) of (NonConcurrent, NonConcurrent) -> a (Concurrent n, _) -> @@ -258,7 +258,7 @@ startConcurrency usedstages a = do - May be called repeatedly by the same thread without blocking. -} ensureOnlyActionOn :: Key -> Annex a -> Annex a ensureOnlyActionOn k a = debugLocks $ - go =<< Annex.getState Annex.concurrency + go =<< getConcurrency where go NonConcurrent = a go (Concurrent _) = goconcurrent diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index 10cb613a36..22f07045ce 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -392,7 +392,7 @@ jsonProgressOption = -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = - [ globalSetter setConcurrency $ + [ globalSetter (setConcurrency . ConcurrencyCmdLine) $ option (maybeReader parseConcurrency) ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") diff --git a/Messages.hs b/Messages.hs index 324f47b167..07b152c24a 100644 --- a/Messages.hs +++ b/Messages.hs @@ -68,6 +68,7 @@ import Types.Command (StartMessage(..), SeekInput) import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent +import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex @@ -298,7 +299,7 @@ prompt a = do {- Like prompt, but for a non-annex action that prompts. -} mkPrompter :: (MonadMask m, MonadIO m) => Annex (m a -> m a) -mkPrompter = Annex.getState Annex.concurrency >>= \case +mkPrompter = getConcurrency >>= \case NonConcurrent -> return id (Concurrent _) -> goconcurrent ConcurrentPerCpu -> goconcurrent diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs index abae4a7729..ccab1ee0a9 100644 --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -17,3 +17,8 @@ parseConcurrency :: String -> Maybe Concurrency parseConcurrency "cpus" = Just ConcurrentPerCpu parseConcurrency "cpu" = Just ConcurrentPerCpu parseConcurrency s = Concurrent <$> readish s + +-- Concurrency can be configured at the command line or by git config. +data ConcurrencySetting + = ConcurrencyCmdLine Concurrency + | ConcurrencyGitConfig Concurrency