Commit ef65b154 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

testsuite/timeout: Fix windows specific errors.

We now seem to use -Werror there. Which caused some long standing
warnings to become errors.

I applied changes to remove the warnings allowing the testsuite to
run on windows as well.
parent 45a1d493
......@@ -29,11 +29,11 @@ data PROCESS_INFORMATION = PROCESS_INFORMATION
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)
poke buf pinfo = do
(#poke PROCESS_INFORMATION, hProcess) buf (piProcess pinfo)
(#poke PROCESS_INFORMATION, hThread) buf (piThread pinfo)
(#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pinfo)
(#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pinfo)
peek buf = do
vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf
......@@ -361,7 +361,7 @@ createCompletionPort hJob = do
return nullPtr
waitForJobCompletion :: HANDLE -> HANDLE -> DWORD -> IO BOOL
waitForJobCompletion hJob ioPort timeout
waitForJobCompletion _hJob ioPort timeout
= alloca $ \p_CompletionCode ->
alloca $ \p_CompletionKey ->
alloca $ \p_Overlapped -> do
......
......@@ -2,22 +2,25 @@
{-# LANGUAGE LambdaCase #-}
module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
import Control.Monad
import Control.Exception
import Data.Maybe (isNothing)
import System.Environment (getArgs)
import System.Exit
import System.IO (hPutStrLn, stderr)
import Prelude hiding (pi)
#if !defined(mingw32_HOST_OS)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
import Data.Maybe (isNothing)
import System.Posix hiding (killProcess)
import System.IO.Error hiding (try,catch)
import System.IO (hPutStrLn, stderr)
#endif
#if defined(mingw32_HOST_OS)
import System.Process
-- import System.Process
import WinCBindings
import Foreign
import System.Win32.DebugApi
......@@ -114,8 +117,8 @@ run secs cmd =
-- 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
_ <- 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.
......@@ -132,30 +135,30 @@ run secs cmd =
let handleInterrupt action =
action `onException` terminateJobObject job 99
handleCtrl _ = do
terminateJobObject job 99
closeHandle ioPort
closeHandle job
exitWith (ExitFailure 99)
_ <- terminateJobObject job 99
_ <- closeHandle ioPort
_ <- closeHandle job
_ <- exitWith (ExitFailure 99)
return True
withConsoleCtrlHandler handleCtrl $
handleInterrupt $ do
resumeThread (piThread pi)
_ <- resumeThread (piThread pi)
-- The program is now running
let handle = piProcess pi
let p_handle = piProcess pi
let millisecs = secs * 1000
rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
closeHandle ioPort
_ <- closeHandle ioPort
if not rc
then do terminateJobObject job 99
closeHandle job
then do _ <- terminateJobObject job 99
_ <- closeHandle job
exitWith (ExitFailure 99)
else alloca $ \p_exitCode ->
do terminateJobObject job 0
do _ <- terminateJobObject job 0
-- Ensured it's all really dead.
closeHandle job
r <- getExitCodeProcess handle p_exitCode
_ <- closeHandle job
r <- getExitCodeProcess p_handle p_exitCode
if r
then peek p_exitCode >>= \case
0 -> exitWith ExitSuccess
......
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