Fix timeout's timeout on Windows

Summary:
Timeout has been broken by my previous patch.
The timeout event was not being processed correctly,
as such hanging processes would not be killed as they should
have been.

This corrects it.

Test Plan:
./validate

~/ghc/testsuite/timeout/install-inplace/bin/timeout.exe 10 "sleep 10000s"

Reviewers: austin, RyanGlScott, bgamari

Reviewed By: bgamari

Subscribers: thomie, #ghc_windows_task_force

Differential Revision: https://phabricator.haskell.org/D2880

GHC Trac Issues: #13004

1 files changed, 18 insertions, 15 deletions

diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc
index d9c08ee3a2..36ba01e543 100644
--- a/testsuite/timeout/WinCBindings.hsc
+++ b/testsuite/timeout/WinCBindings.hsc
@@ -369,21 +369,24 @@ waitForJobCompletion hJob ioPort timeout
         loop = do
           res <- getQueuedCompletionStatus ioPort p_CompletionCode p_CompletionKey
                                            p_Overlapped timeout
-          completionCode <- peek p_CompletionCode
-
-          if completionCode == cJOB_OBJECT_MSG_ACTIVE_PROCESS_ZERO
-                     then return ()
-             else if completionCode == cJOB_OBJECT_MSG_EXIT_PROCESS
-                     then loop
-             else if completionCode == cJOB_OBJECT_MSG_NEW_PROCESS
-                     then loop
-                     else loop
-
-    loop
-
-    overlapped    <- peek p_Overlapped
-    completionKey <- peek $ castPtr p_CompletionKey
-    return $ if overlapped == nullPtr && completionKey /= hJob
+          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