From 1cb63a938a45bd2c1338dfcf30d342b8f573e335 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:18:52 +0100 Subject: [PATCH 1/3] Add redundant waitForProcess to make duplication more obvious It can never run because of the throwIO before it --- src/System/Process/Typed.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index 731c0f9..9c69eaf 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -273,7 +273,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- runtime! | isPermissionError e && not multiThreadedRuntime && isWindows -> P.waitForProcess pHandle - | otherwise -> throwIO e + | otherwise -> throwIO e >> P.waitForProcess pHandle Right () -> P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () From ff029bcc17d7e0a067722d5600b92371b45e6568 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:19:37 +0100 Subject: [PATCH 2/3] Remove duplication between branches --- src/System/Process/Typed.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index 9c69eaf..b2a0374 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -257,8 +257,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- then call waitForProcess ourselves Left _ -> do eres <- try $ P.terminateProcess pHandle - ec <- - case eres of + case eres of Left e -- On Windows, with the single-threaded runtime, it -- seems that if a process has already exited, the @@ -272,9 +271,10 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- Recommendation: always use the multi-threaded -- runtime! | isPermissionError e && not multiThreadedRuntime && isWindows -> - P.waitForProcess pHandle - | otherwise -> throwIO e >> P.waitForProcess pHandle - Right () -> P.waitForProcess pHandle + pure () + | otherwise -> throwIO e + Right () -> pure () + ec <- P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () From 8a0026ae15472dd778eb3ad9941270775abadd88 Mon Sep 17 00:00:00 2001 From: Tom Ellis Date: Mon, 22 May 2023 19:32:12 +0100 Subject: [PATCH 3/3] Pull out terminateProcess wrapper function --- src/System/Process/Typed.hs | 39 ++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/System/Process/Typed.hs b/src/System/Process/Typed.hs index b2a0374..c94701a 100644 --- a/src/System/Process/Typed.hs +++ b/src/System/Process/Typed.hs @@ -256,24 +256,7 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do -- Process didn't exit yet, let's terminate it and -- then call waitForProcess ourselves Left _ -> do - eres <- try $ P.terminateProcess pHandle - case eres of - Left e - -- On Windows, with the single-threaded runtime, it - -- seems that if a process has already exited, the - -- call to terminateProcess will fail with a - -- permission denied error. To work around this, we - -- catch this exception and then immediately - -- waitForProcess. There's a chance that there may be - -- other reasons for this permission error to appear, - -- in which case this code may allow us to wait too - -- long for a child process instead of erroring out. - -- Recommendation: always use the multi-threaded - -- runtime! - | isPermissionError e && not multiThreadedRuntime && isWindows -> - pure () - | otherwise -> throwIO e - Right () -> pure () + terminateProcess pHandle ec <- P.waitForProcess pHandle success <- atomically $ tryPutTMVar pExitCode ec evaluate $ assert success () @@ -282,6 +265,26 @@ startProcess pConfig'@ProcessConfig {..} = liftIO $ do where pConfig = clearStreams pConfig' + terminateProcess pHandle = do + eres <- try $ P.terminateProcess pHandle + case eres of + Left e + -- On Windows, with the single-threaded runtime, it + -- seems that if a process has already exited, the + -- call to terminateProcess will fail with a + -- permission denied error. To work around this, we + -- catch this exception and then immediately + -- waitForProcess. There's a chance that there may be + -- other reasons for this permission error to appear, + -- in which case this code may allow us to wait too + -- long for a child process instead of erroring out. + -- Recommendation: always use the multi-threaded + -- runtime! + | isPermissionError e && not multiThreadedRuntime && isWindows -> + pure () + | otherwise -> throwIO e + Right () -> pure () + foreign import ccall unsafe "rtsSupportsBoundThreads" multiThreadedRuntime :: Bool