[Git][ghc/ghc][master] testsuite/timeout: Fix windows specific errors.
Marge Bot
gitlab at gitlab.haskell.org
Fri Oct 9 12:45:49 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ef65b154 by Andreas Klebinger at 2020-10-09T08:45:42-04:00
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.
- - - - -
2 changed files:
- testsuite/timeout/WinCBindings.hsc
- testsuite/timeout/timeout.hs
Changes:
=====================================
testsuite/timeout/WinCBindings.hsc
=====================================
@@ -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
=====================================
testsuite/timeout/timeout.hs
=====================================
@@ -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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef65b1546ad01fdd10386f713fc246d49269a196
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef65b1546ad01fdd10386f713fc246d49269a196
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201009/ab81c0b6/attachment-0001.html>
More information about the ghc-commits
mailing list