[commit: ghc] master: Fix timeout's timeout on Windows (6263e10)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/6263e1079a2d203fbd2e668ca99c0e901fcd1548/ghc

>---------------------------------------------------------------

commit 6263e1079a2d203fbd2e668ca99c0e901fcd1548
Author: Tamar Christina <tamar at zhox.com>
Date:   Mon Dec 19 00:18:57 2016 +0000

    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


>---------------------------------------------------------------

6263e1079a2d203fbd2e668ca99c0e901fcd1548
 testsuite/timeout/WinCBindings.hsc | 33 ++++++++++++++++++---------------
 1 file changed, 18 insertions(+), 15 deletions(-)

diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc
index d9c08ee..36ba01e 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