Fix timeout's timeout on Windows
authorTamar Christina <tamar@zhox.com>
Mon, 19 Dec 2016 00:18:57 +0000 (00:18 +0000)
committerTamar Christina <tamar@zhox.com>
Mon, 19 Dec 2016 23:19:01 +0000 (23:19 +0000)
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

testsuite/timeout/WinCBindings.hsc

index d9c08ee..36ba01e 100644 (file)
@@ -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