diff options
| -rw-r--r-- | testsuite/timeout/WinCBindings.hsc | 8 | ||||
| -rw-r--r-- | testsuite/timeout/timeout.hs | 8 |
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 |