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

2 files changed, 15 insertions, 1 deletions

diff --git a/testsuite/timeout/WinCBindings.hsc b/testsuite/timeout/WinCBindings.hsc
index 36ba01e543..0c4ff3f5b4 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 cf6c448472..4e97c5ce73 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