[Git][ghc/ghc][wip/andreask/fix_timeout_warnings] testsuite/timeout: Fix windows specific errors.

[Andreas Klebinger]

Andreas Klebinger pushed to branch wip/andreask/fix_timeout_warnings at Glasgow Haskell Compiler / GHC


Commits:
adb769b4 by Andreas Klebinger at 2020-10-01T17:18:37+02: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/adb769b40ebbb9ce7bcc4a96b29b2542ac604053

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/adb769b40ebbb9ce7bcc4a96b29b2542ac604053
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/20201001/752efd3f/attachment-0001.html>