testsuite: Rewrite timeoutwip/timeout-rewrite

3 files changed, 45 insertions, 535 deletions

diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc
deleted file mode 100644
index 36379301a4..0000000000
--- a/testsuite/timeout/WinCBindings.hsc
+++ /dev/null
@@ -1,397 +0,0 @@
-{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-module WinCBindings where
-
-#if defined(mingw32_HOST_OS)
-
-##if defined(i386_HOST_ARCH)
-## define WINDOWS_CCONV stdcall
-##elif defined(x86_64_HOST_ARCH)
-## define WINDOWS_CCONV ccall
-##else
-## error Unknown mingw32 arch
-##endif
-
-import Foreign
-import Foreign.C.Types
-import System.Win32.File
-import System.Win32.Types
-
-#include <windows.h>
-
-type LPPROCESS_INFORMATION = Ptr PROCESS_INFORMATION
-data PROCESS_INFORMATION = PROCESS_INFORMATION
-    { piProcess :: HANDLE
-    , piThread :: HANDLE
-    , piProcessId :: DWORD
-    , piThreadId :: DWORD
-    } deriving Show
-
-instance Storable PROCESS_INFORMATION where
-    sizeOf = const #size PROCESS_INFORMATION
-    alignment = sizeOf
-    poke buf pi = do
-        (#poke PROCESS_INFORMATION, hProcess)    buf (piProcess   pi)
-        (#poke PROCESS_INFORMATION, hThread)     buf (piThread    pi)
-        (#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi)
-        (#poke PROCESS_INFORMATION, dwThreadId)  buf (piThreadId  pi)
-
-    peek buf = do
-        vhProcess    <- (#peek PROCESS_INFORMATION, hProcess)    buf
-        vhThread     <- (#peek PROCESS_INFORMATION, hThread)     buf
-        vdwProcessId <- (#peek PROCESS_INFORMATION, dwProcessId) buf
-        vdwThreadId  <- (#peek PROCESS_INFORMATION, dwThreadId)  buf
-        return $ PROCESS_INFORMATION {
-            piProcess   = vhProcess,
-            piThread    = vhThread,
-            piProcessId = vdwProcessId,
-            piThreadId  = vdwThreadId}
-
-type LPSTARTUPINFO = Ptr STARTUPINFO
-data STARTUPINFO = STARTUPINFO
-    { siCb :: DWORD
-    , siDesktop :: LPTSTR
-    , siTitle :: LPTSTR
-    , siX :: DWORD
-    , siY :: DWORD
-    , siXSize :: DWORD
-    , siYSize :: DWORD
-    , siXCountChars :: DWORD
-    , siYCountChars :: DWORD
-    , siFillAttribute :: DWORD
-    , siFlags :: DWORD
-    , siShowWindow :: WORD
-    , siStdInput :: HANDLE
-    , siStdOutput :: HANDLE
-    , siStdError :: HANDLE
-    } deriving Show
-
-instance Storable STARTUPINFO where
-    sizeOf = const #size STARTUPINFO
-    alignment = sizeOf
-    poke buf si = do
-        (#poke STARTUPINFO, cb)              buf (siCb si)
-        (#poke STARTUPINFO, lpDesktop)       buf (siDesktop si)
-        (#poke STARTUPINFO, lpTitle)         buf (siTitle si)
-        (#poke STARTUPINFO, dwX)             buf (siX si)
-        (#poke STARTUPINFO, dwY)             buf (siY si)
-        (#poke STARTUPINFO, dwXSize)         buf (siXSize si)
-        (#poke STARTUPINFO, dwYSize)         buf (siYSize si)
-        (#poke STARTUPINFO, dwXCountChars)   buf (siXCountChars si)
-        (#poke STARTUPINFO, dwYCountChars)   buf (siYCountChars si)
-        (#poke STARTUPINFO, dwFillAttribute) buf (siFillAttribute si)
-        (#poke STARTUPINFO, dwFlags)         buf (siFlags si)
-        (#poke STARTUPINFO, wShowWindow)     buf (siShowWindow si)
-        (#poke STARTUPINFO, hStdInput)       buf (siStdInput si)
-        (#poke STARTUPINFO, hStdOutput)      buf (siStdOutput si)
-        (#poke STARTUPINFO, hStdError)       buf (siStdError si)
-
-    peek buf = do
-        vcb              <- (#peek STARTUPINFO, cb)              buf
-        vlpDesktop       <- (#peek STARTUPINFO, lpDesktop)       buf
-        vlpTitle         <- (#peek STARTUPINFO, lpTitle)         buf
-        vdwX             <- (#peek STARTUPINFO, dwX)             buf
-        vdwY             <- (#peek STARTUPINFO, dwY)             buf
-        vdwXSize         <- (#peek STARTUPINFO, dwXSize)         buf
-        vdwYSize         <- (#peek STARTUPINFO, dwYSize)         buf
-        vdwXCountChars   <- (#peek STARTUPINFO, dwXCountChars)   buf
-        vdwYCountChars   <- (#peek STARTUPINFO, dwYCountChars)   buf
-        vdwFillAttribute <- (#peek STARTUPINFO, dwFillAttribute) buf
-        vdwFlags         <- (#peek STARTUPINFO, dwFlags)         buf
-        vwShowWindow     <- (#peek STARTUPINFO, wShowWindow)     buf
-        vhStdInput       <- (#peek STARTUPINFO, hStdInput)       buf
-        vhStdOutput      <- (#peek STARTUPINFO, hStdOutput)      buf
-        vhStdError       <- (#peek STARTUPINFO, hStdError)       buf
-        return $ STARTUPINFO {
-            siCb            =  vcb,
-            siDesktop       =  vlpDesktop,
-            siTitle         =  vlpTitle,
-            siX             =  vdwX,
-            siY             =  vdwY,
-            siXSize         =  vdwXSize,
-            siYSize         =  vdwYSize,
-            siXCountChars   =  vdwXCountChars,
-            siYCountChars   =  vdwYCountChars,
-            siFillAttribute =  vdwFillAttribute,
-            siFlags         =  vdwFlags,
-            siShowWindow    =  vwShowWindow,
-            siStdInput      =  vhStdInput,
-            siStdOutput     =  vhStdOutput,
-            siStdError      =  vhStdError}
-
-data JOBOBJECT_EXTENDED_LIMIT_INFORMATION = JOBOBJECT_EXTENDED_LIMIT_INFORMATION
-    { jeliBasicLimitInformation :: JOBOBJECT_BASIC_LIMIT_INFORMATION
-    , jeliIoInfo                :: IO_COUNTERS
-    , jeliProcessMemoryLimit    :: SIZE_T
-    , jeliJobMemoryLimit        :: SIZE_T
-    , jeliPeakProcessMemoryUsed :: SIZE_T
-    , jeliPeakJobMemoryUsed     :: SIZE_T
-    } deriving Show
-
-instance Storable JOBOBJECT_EXTENDED_LIMIT_INFORMATION where
-    sizeOf = const #size JOBOBJECT_EXTENDED_LIMIT_INFORMATION
-    alignment = const #alignment JOBOBJECT_EXTENDED_LIMIT_INFORMATION
-    poke buf jeli = do
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation) buf (jeliBasicLimitInformation jeli)
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, IoInfo)                buf (jeliIoInfo jeli)
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, ProcessMemoryLimit)    buf (jeliProcessMemoryLimit jeli)
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, JobMemoryLimit)        buf (jeliJobMemoryLimit jeli)
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakProcessMemoryUsed) buf (jeliPeakProcessMemoryUsed jeli)
-        (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakJobMemoryUsed)     buf (jeliPeakJobMemoryUsed jeli)
-    peek buf = do
-        vBasicLimitInformation <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation) buf
-        vIoInfo                <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, IoInfo)                buf
-        vProcessMemoryLimit    <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, ProcessMemoryLimit)    buf
-        vJobMemoryLimit        <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, JobMemoryLimit)        buf
-        vPeakProcessMemoryUsed <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakProcessMemoryUsed) buf
-        vPeakJobMemoryUsed     <- (#peek JOBOBJECT_EXTENDED_LIMIT_INFORMATION, PeakJobMemoryUsed)     buf
-        return $ JOBOBJECT_EXTENDED_LIMIT_INFORMATION {
-            jeliBasicLimitInformation = vBasicLimitInformation,
-            jeliIoInfo                = vIoInfo,
-            jeliProcessMemoryLimit    = vProcessMemoryLimit,
-            jeliJobMemoryLimit        = vJobMemoryLimit,
-            jeliPeakProcessMemoryUsed = vPeakProcessMemoryUsed,
-            jeliPeakJobMemoryUsed     = vPeakJobMemoryUsed}
-
-type ULONGLONG = #type ULONGLONG
-
-data IO_COUNTERS = IO_COUNTERS
-    { icReadOperationCount  :: ULONGLONG
-    , icWriteOperationCount :: ULONGLONG
-    , icOtherOperationCount :: ULONGLONG
-    , icReadTransferCount   :: ULONGLONG
-    , icWriteTransferCount  :: ULONGLONG
-    , icOtherTransferCount  :: ULONGLONG
-    } deriving Show
-
-instance Storable IO_COUNTERS where
-    sizeOf = const #size IO_COUNTERS
-    alignment = const #alignment IO_COUNTERS
-    poke buf ic = do
-        (#poke IO_COUNTERS, ReadOperationCount)  buf (icReadOperationCount ic)
-        (#poke IO_COUNTERS, WriteOperationCount) buf (icWriteOperationCount ic)
-        (#poke IO_COUNTERS, OtherOperationCount) buf (icOtherOperationCount ic)
-        (#poke IO_COUNTERS, ReadTransferCount)   buf (icReadTransferCount ic)
-        (#poke IO_COUNTERS, WriteTransferCount)  buf (icWriteTransferCount ic)
-        (#poke IO_COUNTERS, OtherTransferCount)  buf (icOtherTransferCount ic)
-    peek buf = do
-        vReadOperationCount  <- (#peek IO_COUNTERS, ReadOperationCount)  buf
-        vWriteOperationCount <- (#peek IO_COUNTERS, WriteOperationCount) buf
-        vOtherOperationCount <- (#peek IO_COUNTERS, OtherOperationCount) buf
-        vReadTransferCount   <- (#peek IO_COUNTERS, ReadTransferCount)   buf
-        vWriteTransferCount  <- (#peek IO_COUNTERS, WriteTransferCount)  buf
-        vOtherTransferCount  <- (#peek IO_COUNTERS, OtherTransferCount)  buf
-        return $ IO_COUNTERS {
-            icReadOperationCount  = vReadOperationCount,
-            icWriteOperationCount = vWriteOperationCount,
-            icOtherOperationCount = vOtherOperationCount,
-            icReadTransferCount   = vReadTransferCount,
-            icWriteTransferCount  = vWriteTransferCount,
-            icOtherTransferCount  = vOtherTransferCount}
-
-data JOBOBJECT_BASIC_LIMIT_INFORMATION = JOBOBJECT_BASIC_LIMIT_INFORMATION
-    { jbliPerProcessUserTimeLimit :: LARGE_INTEGER
-    , jbliPerJobUserTimeLimit     :: LARGE_INTEGER
-    , jbliLimitFlags              :: DWORD
-    , jbliMinimumWorkingSetSize   :: SIZE_T
-    , jbliMaximumWorkingSetSize   :: SIZE_T
-    , jbliActiveProcessLimit      :: DWORD
-    , jbliAffinity                :: ULONG_PTR
-    , jbliPriorityClass           :: DWORD
-    , jbliSchedulingClass         :: DWORD
-    } deriving Show
-
-instance Storable JOBOBJECT_BASIC_LIMIT_INFORMATION where
-    sizeOf = const #size JOBOBJECT_BASIC_LIMIT_INFORMATION
-    alignment = const #alignment JOBOBJECT_BASIC_LIMIT_INFORMATION
-    poke buf jbli = do
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PerProcessUserTimeLimit) buf (jbliPerProcessUserTimeLimit jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PerJobUserTimeLimit)     buf (jbliPerJobUserTimeLimit jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, LimitFlags)              buf (jbliLimitFlags jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, MinimumWorkingSetSize)   buf (jbliMinimumWorkingSetSize jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, MaximumWorkingSetSize)   buf (jbliMaximumWorkingSetSize jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, ActiveProcessLimit)      buf (jbliActiveProcessLimit jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, Affinity)                buf (jbliAffinity jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, PriorityClass)           buf (jbliPriorityClass jbli)
-        (#poke JOBOBJECT_BASIC_LIMIT_INFORMATION, SchedulingClass)         buf (jbliSchedulingClass jbli)
-    peek buf = do
-        vPerProcessUserTimeLimit <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PerProcessUserTimeLimit) buf
-        vPerJobUserTimeLimit     <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PerJobUserTimeLimit)     buf
-        vLimitFlags              <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, LimitFlags)              buf
-        vMinimumWorkingSetSize   <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, MinimumWorkingSetSize)   buf
-        vMaximumWorkingSetSize   <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, MaximumWorkingSetSize)   buf
-        vActiveProcessLimit      <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, ActiveProcessLimit)      buf
-        vAffinity                <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, Affinity)                buf
-        vPriorityClass           <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, PriorityClass)           buf
-        vSchedulingClass         <- (#peek JOBOBJECT_BASIC_LIMIT_INFORMATION, SchedulingClass)         buf
-        return $ JOBOBJECT_BASIC_LIMIT_INFORMATION {
-            jbliPerProcessUserTimeLimit = vPerProcessUserTimeLimit,
-            jbliPerJobUserTimeLimit     = vPerJobUserTimeLimit,
-            jbliLimitFlags              = vLimitFlags,
-            jbliMinimumWorkingSetSize   = vMinimumWorkingSetSize,
-            jbliMaximumWorkingSetSize   = vMaximumWorkingSetSize,
-            jbliActiveProcessLimit      = vActiveProcessLimit,
-            jbliAffinity                = vAffinity,
-            jbliPriorityClass           = vPriorityClass,
-            jbliSchedulingClass         = vSchedulingClass}
-
-data JOBOBJECT_ASSOCIATE_COMPLETION_PORT = JOBOBJECT_ASSOCIATE_COMPLETION_PORT
-    { jacpCompletionKey  :: PVOID
-    , jacpCompletionPort :: HANDLE
-    } deriving Show
-
-instance Storable JOBOBJECT_ASSOCIATE_COMPLETION_PORT where
-    sizeOf = const #size JOBOBJECT_ASSOCIATE_COMPLETION_PORT
-    alignment = const #alignment JOBOBJECT_ASSOCIATE_COMPLETION_PORT
-    poke buf jacp = do
-        (#poke JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionKey)  buf (jacpCompletionKey jacp)
-        (#poke JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionPort) buf (jacpCompletionPort jacp)
-    peek buf = do
-        vCompletionKey  <- (#peek JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionKey)  buf
-        vCompletionPort <- (#peek JOBOBJECT_ASSOCIATE_COMPLETION_PORT, CompletionPort) buf
-        return $ JOBOBJECT_ASSOCIATE_COMPLETION_PORT {
-            jacpCompletionKey  = vCompletionKey,
-            jacpCompletionPort = vCompletionPort}
-
-
-foreign import WINDOWS_CCONV unsafe "windows.h WaitForSingleObject"
-    waitForSingleObject :: HANDLE -> DWORD -> IO DWORD
-
-type JOBOBJECTINFOCLASS = CInt
-
-type PVOID = Ptr ()
-type PULONG_PTR = Ptr ULONG_PTR
-
-jobObjectExtendedLimitInformation :: JOBOBJECTINFOCLASS
-jobObjectExtendedLimitInformation = #const JobObjectExtendedLimitInformation
-
-jobObjectAssociateCompletionPortInformation :: JOBOBJECTINFOCLASS
-jobObjectAssociateCompletionPortInformation = #const JobObjectAssociateCompletionPortInformation
-
-cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE :: DWORD
-cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE = #const JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
-
-cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO :: DWORD
-cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO = #const JOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
-
-cJOB_OBJECT_MSG_EXIT_PROCESS :: DWORD
-cJOB_OBJECT_MSG_EXIT_PROCESS = #const JOB_OBJECT_MSG_EXIT_PROCESS
-
-cJOB_OBJECT_MSG_NEW_PROCESS :: DWORD
-cJOB_OBJECT_MSG_NEW_PROCESS = #const JOB_OBJECT_MSG_NEW_PROCESS
-
-cWAIT_ABANDONED :: DWORD
-cWAIT_ABANDONED = #const WAIT_ABANDONED
-
-cWAIT_OBJECT_0 :: DWORD
-cWAIT_OBJECT_0 = #const WAIT_OBJECT_0
-
-cWAIT_TIMEOUT :: DWORD
-cWAIT_TIMEOUT = #const WAIT_TIMEOUT
-
-cCREATE_SUSPENDED :: DWORD
-cCREATE_SUSPENDED = #const CREATE_SUSPENDED
-
-cHANDLE_FLAG_INHERIT :: DWORD
-cHANDLE_FLAG_INHERIT = #const HANDLE_FLAG_INHERIT
-
-foreign import WINDOWS_CCONV unsafe "windows.h GetExitCodeProcess"
-    getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h CloseHandle"
-    closeHandle :: HANDLE -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h TerminateJobObject"
-    terminateJobObject :: HANDLE -> UINT -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h AssignProcessToJobObject"
-    assignProcessToJobObject :: HANDLE -> HANDLE -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h CreateJobObjectW"
-    createJobObjectW :: LPSECURITY_ATTRIBUTES -> LPCTSTR -> IO HANDLE
-
-foreign import WINDOWS_CCONV unsafe "windows.h CreateProcessW"
-    createProcessW :: LPCTSTR -> LPTSTR
-                   -> LPSECURITY_ATTRIBUTES -> LPSECURITY_ATTRIBUTES
-                   -> BOOL -> DWORD -> LPVOID -> LPCTSTR -> LPSTARTUPINFO
-                   -> LPPROCESS_INFORMATION -> IO BOOL
-
-foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)
-
-foreign import WINDOWS_CCONV unsafe "windows.h SetInformationJobObject"
-    setInformationJobObject :: HANDLE -> JOBOBJECTINFOCLASS -> LPVOID -> DWORD -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h CreateIoCompletionPort"
-    createIoCompletionPort :: HANDLE -> HANDLE -> ULONG_PTR -> DWORD -> IO HANDLE
-
-foreign import WINDOWS_CCONV unsafe "windows.h GetQueuedCompletionStatus"
-    getQueuedCompletionStatus :: HANDLE -> LPDWORD -> PULONG_PTR -> Ptr LPOVERLAPPED -> DWORD -> IO BOOL
-
-foreign import WINDOWS_CCONV unsafe "windows.h SetHandleInformation"
-    setHandleInformation :: HANDLE -> DWORD -> DWORD -> IO BOOL
-
-setJobParameters :: HANDLE -> IO BOOL
-setJobParameters hJob = alloca $ \p_jeli -> do
-    let jeliSize = sizeOf (undefined :: JOBOBJECT_EXTENDED_LIMIT_INFORMATION)
-
-    _ <- memset p_jeli 0 $ fromIntegral jeliSize
-    -- Configure all child processes associated with the job to terminate when the
-    -- last handle to the job is closed. This prevent half dead processes and that
-    -- hanging ghc-iserv.exe process that happens when you interrupt the testsuite.
-    (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation.LimitFlags)
-      p_jeli cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
-    setInformationJobObject hJob jobObjectExtendedLimitInformation
-                            p_jeli (fromIntegral jeliSize)
-
-createCompletionPort :: HANDLE -> IO HANDLE
-createCompletionPort hJob = do
-    ioPort <- createIoCompletionPort iNVALID_HANDLE_VALUE nullPtr 0 1
-    if ioPort == nullPtr
-       then do err_code <- getLastError
-               putStrLn $ "CreateIoCompletionPort error: " ++ show err_code
-               return nullPtr
-       else with (JOBOBJECT_ASSOCIATE_COMPLETION_PORT {
-                    jacpCompletionKey  = hJob,
-                    jacpCompletionPort = ioPort}) $ \p_Port -> do
-              res <- setInformationJobObject hJob jobObjectAssociateCompletionPortInformation
-                         (castPtr p_Port) (fromIntegral (sizeOf (undefined :: JOBOBJECT_ASSOCIATE_COMPLETION_PORT)))
-              if res
-                 then return ioPort
-                 else do err_code <- getLastError
-                         putStrLn $ "SetInformation, error: " ++ show err_code
-                         return nullPtr
-
-waitForJobCompletion :: HANDLE -> HANDLE -> DWORD -> IO BOOL
-waitForJobCompletion hJob ioPort timeout
-  = alloca $ \p_CompletionCode ->
-    alloca $ \p_CompletionKey ->
-    alloca $ \p_Overlapped -> do
-
-    -- getQueuedCompletionStatus is a blocking call,
-    -- it will wake up for each completion event. So if it's
-    -- not the one we want, sleep again.
-    let loop :: IO ()
-        loop = do
-          res <- getQueuedCompletionStatus ioPort p_CompletionCode p_CompletionKey
-                                           p_Overlapped timeout
-          case res of
-            False -> return ()
-            True  -> do
-                completionCode <- peek p_CompletionCode
-                if completionCode == cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
-                           then return ()
-                   else if completionCode == cJOB_OBJECT_MSG_EXIT_PROCESS
-                           then loop -- Debug point, do nothing for now
-                   else if completionCode == cJOB_OBJECT_MSG_NEW_PROCESS
-                           then loop -- Debug point, do nothing for now
-                           else loop
-
-    loop -- Kick it all off
-
-    overlapped <- peek p_Overlapped
-    code       <- peek $ p_CompletionCode
-
-    return $ if overlapped == nullPtr && code /= cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
-                then False -- Timeout occurred. *dark voice* YOU HAVE FAILED THIS TEST!.
-                else True
-#endif
-
diff --git a/testsuite/timeout/timeout.cabal b/testsuite/timeout/timeout.cabal
index 0ada69b43f..1a0d8891c9 100644
--- a/testsuite/timeout/timeout.cabal
+++ b/testsuite/timeout/timeout.cabal
@@ -2,8 +2,8 @@ Name: timeout
 Version: 1
 Copyright: GHC Team
 License: BSD3
-Author: GHC Team <cvs-ghc@haskell.org>
-Maintainer: GHC Team <cvs-ghc@haskell.org>
+Author: GHC Team <ghc-devs@haskell.org>
+Maintainer: GHC Team <ghc-devs@haskell.org>
 Synopsis: timeout utility
 Description: timeout utility
 Category: Development
@@ -12,11 +12,7 @@ cabal-version: >=1.2
 
 Executable timeout
     Main-Is: timeout.hs
-    Other-Modules: WinCBindings
     Extensions: CPP
+    Ghc-Options: -threaded
     Build-Depends: base, process
-    if os(windows)
-        Build-Depends: Win32
-    else
-        Build-Depends: unix
 
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index 9f3044f36d..a156fbbce3 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -3,27 +3,15 @@
 module Main where
 
 import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
+import Control.Concurrent.MVar
 import Control.Monad
 import Control.Exception
 import Data.Maybe (isNothing)
 import System.Environment (getArgs)
 import System.Exit
+import System.Process
 import System.IO (hPutStrLn, stderr)
-
-#if !defined(mingw32_HOST_OS)
-import System.Posix hiding (killProcess)
 import System.IO.Error hiding (try,catch)
-#endif
-
-#if defined(mingw32_HOST_OS)
-import System.Process
-import WinCBindings
-import Foreign
-import System.Win32.DebugApi
-import System.Win32.Types
-import System.Win32.Console.CtrlHandler
-#endif
 
 main :: IO ()
 main = do
@@ -35,22 +23,40 @@ main = do
           _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")
       _ -> die ("Bad arguments " ++ show args)
 
+data FinishedReason
+    = TimedOut
+    | Exited ExitCode
+    | InterruptedSignal
+    | OtherError SomeException
+
 run :: Int -> String -> IO ()
-#if !defined(mingw32_HOST_OS)
 run secs cmd = do
-        m <- newEmptyMVar
-        mp <- newEmptyMVar
-        installHandler sigINT (Catch (putMVar m Nothing)) Nothing
-        forkIO $ do threadDelay (secs * 1000000)
-                    putMVar m Nothing
-        forkIO $ do ei <- try $ do pid <- systemSession cmd
-                                   return pid
-                    putMVar mp ei
-                    case ei of
-                       Left _ -> return ()
-                       Right pid -> do
-                           r <- getProcessStatus True False pid
-                           putMVar m r
+    m <- newEmptyMVar :: IO (MVar FinishedReason)
+    mp <- newEmptyMVar :: IO (MVar (Either IOException ProcessHandle))
+
+    -- The timeout thread
+    forkIO $ do
+        threadDelay (secs * 1000000)
+        putMVar m TimedOut
+
+    -- the process itself
+    forkIO $ handle (\exc -> putMVar mp $ Left (userError $ show (exc :: SomeException))) $ do
+        ei <- fmap (fmap (\(_,_,_,ph) -> ph)) $ try $ createProcess (shell cmd)
+            { new_session = True
+            , use_process_jobs = True
+            }
+        putMVar mp ei
+        case ei of
+           Left _ -> return ()
+           Right pid -> do
+               r <- waitForProcess pid
+               putMVar m (Exited r)
+
+    -- Be sure to catch SIGINT while waiting
+    let handleINT UserInterrupt = putMVar m InterruptedSignal
+        handleINT other = throwIO other
+
+    handle handleINT $ do
         ei_pid_ph <- takeMVar mp
         case ei_pid_ph of
             Left e -> do hPutStrLn stderr
@@ -59,107 +65,12 @@ run secs cmd = do
             Right pid -> do
                 r <- takeMVar m
                 case r of
-                  Nothing -> do
-                        killProcess pid
-                        exitWith (ExitFailure 99)
-                  Just (Exited r) -> exitWith r
-                  Just (Terminated s) -> raiseSignal s
-                  Just _ -> exitWith (ExitFailure 1)
-
-systemSession cmd =
- forkProcess $ do
-   createSession
-   executeFile "/bin/sh" False ["-c", cmd] Nothing
-   -- need to use exec() directly here, rather than something like
-   -- System.Process.system, because we are in a forked child and some
-   -- pthread libraries get all upset if you start doing certain
-   -- things in a forked child of a pthread process, such as forking
-   -- more threads.
-
-killProcess pid = do
-  ignoreIOExceptions (signalProcessGroup sigTERM pid)
-  checkReallyDead 10
-  where
-    checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
-    checkReallyDead (n+1) =
-      do threadDelay (3*100000) -- 3/10 sec
-         m <- tryJust (guard . isDoesNotExistError) $
-                 getProcessStatus False False pid
-         case m of
-            Right Nothing -> return ()
-            Left _ -> return ()
-            _ -> do
-              ignoreIOExceptions (signalProcessGroup sigKILL pid)
-              checkReallyDead n
-
-ignoreIOExceptions :: IO () -> IO ()
-ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ())
-
-#else
-run secs cmd =
-    let escape '\\' = "\\\\"
-        escape '"'  = "\\\""
-        escape c    = [c]
-        cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in
-    alloca $ \p_startupinfo ->
-    alloca $ \p_pi ->
-    withTString cmd' $ \cmd'' ->
-    do job <- createJobObjectW nullPtr nullPtr
-       b_info <- setJobParameters job
-       unless b_info $ errorWin "setJobParameters"
-
-       ioPort <- createCompletionPort job
-       when (ioPort == nullPtr) $ errorWin "createCompletionPort, cannot continue."
-
-       -- We're explicitly turning off handle inheritance to prevent misc handles
-       -- from being inherited by the child. Notable we don't want the I/O Completion
-       -- Ports and Job handles to be inherited. So we mark them as non-inheritable.
-       setHandleInformation job    cHANDLE_FLAG_INHERIT 0
-       setHandleInformation ioPort cHANDLE_FLAG_INHERIT 0
-
-       -- Now create the process suspended so we can add it to the job and then resume.
-       -- This is so we don't miss any events on the receiving end of the I/O port.
-       let creationflags = cCREATE_SUSPENDED
-       b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
-                           creationflags
-                           nullPtr nullPtr p_startupinfo p_pi
-       unless b $ errorWin "createProcessW"
-
-       pi <- peek p_pi
-       b_assign <- assignProcessToJobObject job (piProcess pi)
-       unless b_assign $ errorWin "assignProcessToJobObject, cannot continue."
-
-       let handleInterrupt action =
-               action `onException` terminateJobObject job 99
-           handleCtrl _ = do
-               terminateJobObject job 99
-               closeHandle ioPort
-               closeHandle job
-               exitWith (ExitFailure 99)
-               return True
-
-       withConsoleCtrlHandler handleCtrl $
-           handleInterrupt $ do
-              resumeThread (piThread pi)
-              -- The program is now running
-              let handle = piProcess pi
-              let millisecs = secs * 1000
-              rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
-              closeHandle ioPort
-
-              if not rc
-                then do terminateJobObject job 99
-                        closeHandle job
+                  TimedOut -> do
+                        interruptProcessGroupOf pid
+                        terminateProcess pid
                         exitWith (ExitFailure 99)
-                else alloca $ \p_exitCode ->
-                      do terminateJobObject job 0
-                         -- Ensured it's all really dead.
-                         closeHandle job
-                         r <- getExitCodeProcess handle p_exitCode
-                         if r
-                           then peek p_exitCode >>= \case
-                                   0 -> exitWith ExitSuccess
-                                   e -> exitWith $ ExitFailure (fromIntegral e)
-                           else errorWin "getExitCodeProcess"
-#endif
-
+                  InterruptedSignal -> do
+                        interruptProcessGroupOf pid
+                        terminateProcess pid
+                        exitWith (ExitFailure 2)
+                  Exited r -> exitWith r