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 ...@@ -29,11 +29,11 @@ data PROCESS_INFORMATION = PROCESS_INFORMATION
instance Storable PROCESS_INFORMATION where instance Storable PROCESS_INFORMATION where
sizeOf = const #size PROCESS_INFORMATION sizeOf = const #size PROCESS_INFORMATION
alignment = sizeOf alignment = sizeOf
poke buf pi = do poke buf pinfo = do
(#poke PROCESS_INFORMATION, hProcess) buf (piProcess pi) (#poke PROCESS_INFORMATION, hProcess) buf (piProcess pinfo)
(#poke PROCESS_INFORMATION, hThread) buf (piThread pi) (#poke PROCESS_INFORMATION, hThread) buf (piThread pinfo)
(#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pi) (#poke PROCESS_INFORMATION, dwProcessId) buf (piProcessId pinfo)
(#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pi) (#poke PROCESS_INFORMATION, dwThreadId) buf (piThreadId pinfo)
peek buf = do peek buf = do
vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf vhProcess <- (#peek PROCESS_INFORMATION, hProcess) buf
...@@ -361,7 +361,7 @@ createCompletionPort hJob = do ...@@ -361,7 +361,7 @@ createCompletionPort hJob = do
return nullPtr return nullPtr
waitForJobCompletion :: HANDLE -> HANDLE -> DWORD -> IO BOOL waitForJobCompletion :: HANDLE -> HANDLE -> DWORD -> IO BOOL
waitForJobCompletion hJob ioPort timeout waitForJobCompletion _hJob ioPort timeout
= alloca $ \p_CompletionCode -> = alloca $ \p_CompletionCode ->
alloca $ \p_CompletionKey -> alloca $ \p_CompletionKey ->
alloca $ \p_Overlapped -> do alloca $ \p_Overlapped -> do
......
...@@ -2,22 +2,25 @@ ...@@ -2,22 +2,25 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Main where module Main where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
import Control.Monad import Control.Monad
import Control.Exception import Control.Exception
import Data.Maybe (isNothing)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit import System.Exit
import System.IO (hPutStrLn, stderr) import Prelude hiding (pi)
#if !defined(mingw32_HOST_OS) #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.Posix hiding (killProcess)
import System.IO.Error hiding (try,catch) import System.IO.Error hiding (try,catch)
import System.IO (hPutStrLn, stderr)
#endif #endif
#if defined(mingw32_HOST_OS) #if defined(mingw32_HOST_OS)
import System.Process -- import System.Process
import WinCBindings import WinCBindings
import Foreign import Foreign
import System.Win32.DebugApi import System.Win32.DebugApi
...@@ -114,8 +117,8 @@ run secs cmd = ...@@ -114,8 +117,8 @@ run secs cmd =
-- We're explicitly turning off handle inheritance to prevent misc handles -- 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 -- 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. -- Ports and Job handles to be inherited. So we mark them as non-inheritable.
setHandleInformation job cHANDLE_FLAG_INHERIT 0 _ <- setHandleInformation job cHANDLE_FLAG_INHERIT 0
setHandleInformation ioPort 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. -- 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. -- 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 = ...@@ -132,30 +135,30 @@ run secs cmd =
let handleInterrupt action = let handleInterrupt action =
action `onException` terminateJobObject job 99 action `onException` terminateJobObject job 99
handleCtrl _ = do handleCtrl _ = do
terminateJobObject job 99 _ <- terminateJobObject job 99
closeHandle ioPort _ <- closeHandle ioPort
closeHandle job _ <- closeHandle job
exitWith (ExitFailure 99) _ <- exitWith (ExitFailure 99)
return True return True
withConsoleCtrlHandler handleCtrl $ withConsoleCtrlHandler handleCtrl $
handleInterrupt $ do handleInterrupt $ do
resumeThread (piThread pi) _ <- resumeThread (piThread pi)
-- The program is now running -- The program is now running
let handle = piProcess pi let p_handle = piProcess pi
let millisecs = secs * 1000 let millisecs = secs * 1000
rc <- waitForJobCompletion job ioPort (fromIntegral millisecs) rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
closeHandle ioPort _ <- closeHandle ioPort
if not rc if not rc
then do terminateJobObject job 99 then do _ <- terminateJobObject job 99
closeHandle job _ <- closeHandle job
exitWith (ExitFailure 99) exitWith (ExitFailure 99)
else alloca $ \p_exitCode -> else alloca $ \p_exitCode ->
do terminateJobObject job 0 do _ <- terminateJobObject job 0
-- Ensured it's all really dead. -- Ensured it's all really dead.
closeHandle job _ <- closeHandle job
r <- getExitCodeProcess handle p_exitCode r <- getExitCodeProcess p_handle p_exitCode
if r if r
then peek p_exitCode >>= \case then peek p_exitCode >>= \case
0 -> exitWith ExitSuccess 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