[commit: ghc] master: Allow timeout to kill entire process tree. (efc4a16)

[git at git.haskell.org]

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

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

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

commit efc4a1661f0fc1004a4b7b0914f3d3a08c2e791a
Author: Tamar Christina <tamar at zhox.com>
Date:   Fri Dec 23 00:56:34 2016 +0000

    Allow timeout to kill entire process tree.
    
    Summary:
    we spawn the child processes with handle inheritance on. So they inherit the std handles.
    The problem is that the job handle gets inherited too.
    So the `JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE` doesn't get used since there are
    open handles to the job in the children.
    
    We then terminate the top level process which is `sh` but leaves the children around.
    
    This explicitly disallows the inheritance of the job and events handle.
    
    Test Plan: ./validate
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie, #ghc_windows_task_force
    
    Differential Revision: https://phabricator.haskell.org/D2895
    
    GHC Trac Issues: #13004


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

efc4a1661f0fc1004a4b7b0914f3d3a08c2e791a
 testsuite/timeout/WinCBindings.hsc | 8 +++++++-
 testsuite/timeout/timeout.hs       | 8 ++++++++
 2 files changed, 15 insertions(+), 1 deletion(-)

diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc
index 36ba01e..0c4ff3f 100644
--- a/testsuite/timeout/WinCBindings.hsc
+++ b/testsuite/timeout/WinCBindings.hsc
@@ -293,6 +293,9 @@ cWAIT_TIMEOUT = #const WAIT_TIMEOUT
 cCREATE_SUSPENDED :: DWORD
 cCREATE_SUSPENDED = #const CREATE_SUSPENDED
 
+cHANDLE_FLAG_INHERIT :: DWORD
+cHANDLE_FLAG_INHERIT = #const HANDLE_FLAG_INHERIT
+
 foreign import WINDOWS_CCONV unsafe "windows.h GetExitCodeProcess"
     getExitCodeProcess :: HANDLE -> LPDWORD -> IO BOOL
 
@@ -325,13 +328,16 @@ foreign import WINDOWS_CCONV unsafe "windows.h CreateIoCompletionPort"
 foreign import WINDOWS_CCONV unsafe "windows.h GetQueuedCompletionStatus"
     getQueuedCompletionStatus :: HANDLE -> LPDWORD -> PULONG_PTR -> Ptr LPOVERLAPPED -> DWORD -> IO BOOL
 
+foreign import WINDOWS_CCONV unsafe "windows.h SetHandleInformation"
+    setHandleInformation :: HANDLE -> DWORD -> DWORD -> IO BOOL
+
 setJobParameters :: HANDLE -> IO BOOL
 setJobParameters hJob = alloca $ \p_jeli -> do
     let jeliSize = sizeOf (undefined :: JOBOBJECT_EXTENDED_LIMIT_INFORMATION)
 
     _ <- memset p_jeli 0 $ fromIntegral jeliSize
     -- Configure all child processes associated with the job to terminate when the
-    -- Last process in the job terminates. This prevent half dead processes and that
+    -- last handle to the job is closed. This prevent half dead processes and that
     -- hanging ghc-iserv.exe process that happens when you interrupt the testsuite.
     (#poke JOBOBJECT_EXTENDED_LIMIT_INFORMATION, BasicLimitInformation.LimitFlags)
       p_jeli cJOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE
diff --git a/testsuite/timeout/timeout.hs b/testsuite/timeout/timeout.hs
index cf6c448..4e97c5c 100644
--- a/testsuite/timeout/timeout.hs
+++ b/testsuite/timeout/timeout.hs
@@ -109,6 +109,14 @@ run secs cmd =
        ioPort <- createCompletionPort job
        when (ioPort == nullPtr) $ errorWin "createCompletionPort, cannot continue."
 
+       -- 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 CP and
+       -- Job handles to be inherited. So we mark them as non-inheritable.
+       setHandleInformation job cHANDLE_FLAG_INHERIT 0
+       setHandleInformation job 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.
        let creationflags = cCREATE_SUSPENDED
        b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
                            creationflags