Commit c6ee773a authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

testsuite/timeout: Ensure that processes are cleaned up on Windows

Previously if the test is interrupted (e.g. with Ctrl-C) any processes
which it spawned may not be properly terminated. Here we catch any
exception and ensure that we job is terminated.

Test Plan: Validate on Windows

Reviewers: Phyx, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2599
parent 8bb960ef
......@@ -110,23 +110,26 @@ run secs cmd =
unless b $ errorWin "createProcessW"
pi <- peek p_pi
assignProcessToJobObject job (piProcess pi)
resumeThread (piThread pi)
let handleInterrupt action =
action `onException` terminateJobObject job 99
handleInterrupt $ do
resumeThread (piThread pi)
-- The program is now running
-- The program is now running
let handle = piProcess pi
let millisecs = secs * 1000
rc <- waitForSingleObject handle (fromIntegral millisecs)
if rc == cWAIT_TIMEOUT
then do terminateJobObject job 99
exitWith (ExitFailure 99)
else alloca $ \p_exitCode ->
do r <- getExitCodeProcess handle p_exitCode
if r then do ec <- peek p_exitCode
let ec' = if ec == 0
then ExitSuccess
else ExitFailure $ fromIntegral ec
exitWith ec'
else errorWin "getExitCodeProcess"
let handle = piProcess pi
let millisecs = secs * 1000
rc <- waitForSingleObject handle (fromIntegral millisecs)
if rc == cWAIT_TIMEOUT
then do terminateJobObject job 99
exitWith (ExitFailure 99)
else alloca $ \p_exitCode ->
do r <- getExitCodeProcess handle p_exitCode
if r then do ec <- peek p_exitCode
let ec' = if ec == 0
then ExitSuccess
else ExitFailure $ fromIntegral ec
exitWith ec'
else errorWin "getExitCodeProcess"
#endif
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment