summaryrefslogtreecommitdiff
path: root/testsuite/timeout
diff options
context:
space:
mode:
authorTamar Christina <tamar@zhox.com>2016-12-23 00:56:34 +0000
committerTamar Christina <tamar@zhox.com>2016-12-23 11:56:08 +0000
commitefc4a1661f0fc1004a4b7b0914f3d3a08c2e791a (patch)
treeca0ad8d41cbc829ab8d1b7a86861affd8c5d565f /testsuite/timeout
parentb7a6e6220289289796d03cf1738e6c77daf6c181 (diff)
downloadhaskell-efc4a1661f0fc1004a4b7b0914f3d3a08c2e791a.tar.gz
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
Diffstat (limited to 'testsuite/timeout')
-rw-r--r--testsuite/timeout/WinCBindings.hsc8
-rw-r--r--testsuite/timeout/timeout.hs8
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