diff options
Diffstat (limited to 'Utility')
-rw-r--r-- | Utility/Batch.hs | 50 |
1 files changed, 26 insertions, 24 deletions
diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 035a2eb..61026f1 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -10,9 +10,6 @@ module Utility.Batch where import Common -#ifndef mingw32_HOST_OS -import qualified Build.SysConfig -#endif #if defined(linux_HOST_OS) || defined(__ANDROID__) import Control.Concurrent.Async @@ -46,36 +43,45 @@ batch a = a maxNice :: Int maxNice = 19 -{- Converts a command to run niced. -} -toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam]) -toBatchCommand (command, params) = (command', params') - where +{- Makes a command be run by whichever of nice, ionice, and nocache + - are available in the path. -} +type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) + +getBatchCommandMaker :: IO BatchCommandMaker +getBatchCommandMaker = do #ifndef mingw32_HOST_OS - commandline = unwords $ map shellEscape $ command : toCommand params - nicedcommand - | Build.SysConfig.nice = "nice " ++ commandline - | otherwise = commandline - command' = "sh" - params' = - [ Param "-c" - , Param $ "exec " ++ nicedcommand + nicers <- filterM (inPath . fst) + [ ("nice", []) + , ("ionice", ["-c3"]) + , ("nocache", []) ] + return $ \(command, params) -> + case nicers of + [] -> (command, params) + (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params) #else - command' = command - params' = params + return id #endif +toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam]) +toBatchCommand v = do + batchmaker <- getBatchCommandMaker + return $ batchmaker v + {- Runs a command in a way that's suitable for batch jobs that can be - interrupted. - - - The command is run niced. If the calling thread receives an async - - exception, it sends the command a SIGTERM, and after the command - - finishes shuttting down, it re-raises the async exception. -} + - If the calling thread receives an async exception, it sends the + - command a SIGTERM, and after the command finishes shuttting down, + - it re-raises the async exception. -} batchCommand :: String -> [CommandParam] -> IO Bool batchCommand command params = batchCommandEnv command params Nothing batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool batchCommandEnv command params environ = do + batchmaker <- getBatchCommandMaker + let (command', params') = batchmaker (command, params) + let p = proc command' $ toCommand params' (_, _, _, pid) <- createProcess $ p { env = environ } r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) case r of @@ -85,7 +91,3 @@ batchCommandEnv command params environ = do terminateProcess pid void $ waitForProcess pid E.throwIO asyncexception - where - (command', params') = toBatchCommand (command, params) - p = proc command' $ toCommand params' - |