[commit: ghc] master: testsuite/timeout: Ensure that processes are cleaned up on Windows (c6ee773)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c6ee773a93397c197caa09db9f8d8145d9d930b0/ghc

>---------------------------------------------------------------

commit c6ee773a93397c197caa09db9f8d8145d9d930b0
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Sun Oct 16 20:49:15 2016 -0400

    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


>---------------------------------------------------------------

c6ee773a93397c197caa09db9f8d8145d9d930b0
 testsuite/timeout/timeout.hs | 35 +++++++++++++++++++----------------
 1 file changed, 19 insertions(+), 16 deletions(-)

diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index 3684b91..c015eb6 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -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