[commit: packages/process] master, wip/issue15: In cleanupProcess, stop the ctl-C delegation synchronously (3b5804e)

[git at git.haskell.org]

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

On branches: master,wip/issue15
Link       : http://ghc.haskell.org/trac/ghc/changeset/3b5804ebe54c672146994cfc525d45280650043e/process

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

commit 3b5804ebe54c672146994cfc525d45280650043e
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Sat Jan 10 20:52:10 2015 +0000

    In cleanupProcess, stop the ctl-C delegation synchronously
    
    So it's immediate, rather than deferred to another thread (and until
    the process actually terminates).


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

3b5804ebe54c672146994cfc525d45280650043e
 System/Process.hsc          | 14 +++++++++++---
 System/Process/Internals.hs |  1 +
 2 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/System/Process.hsc b/System/Process.hsc
index 4fca71e..4aadb50 100644
--- a/System/Process.hsc
+++ b/System/Process.hsc
@@ -236,7 +236,8 @@ withCreateProcess_ fun c action =
 
 cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
                -> IO ()
-cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
+cleanupProcess (mb_stdin, mb_stdout, mb_stderr,
+                ph@(ProcessHandle _ delegating_ctlc)) = do
     terminateProcess ph
     -- Note, it's important that other threads that might be reading/writing
     -- these handles also get killed off, since otherwise they might be holding
@@ -248,9 +249,16 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do
     -- Indeed on Unix it's SIGTERM, which asks nicely but does not guarantee
     -- that it stops. If it doesn't stop, we don't want to hang, so we wait
     -- asynchronously using forkIO.
-    _ <- forkIO (waitForProcess ph >> return ())
-    return ()
 
+    -- However we want to end the Ctl-C handling synchronously, so we'll do
+    -- that synchronously, and set delegating_ctlc as False for the
+    -- waitForProcess (which would otherwise end the Ctl-C delegation itself).
+    when delegating_ctlc
+      stopDelegateControlC
+    _ <- forkIO (waitForProcess (resetCtlcDelegation ph) >> return ())
+    return ()
+  where
+    resetCtlcDelegation (ProcessHandle m _) = ProcessHandle m False
 
 -- ----------------------------------------------------------------------------
 -- spawnProcess/spawnCommand
diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index e46ddb6..e03e12c 100644
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -33,6 +33,7 @@ module System.Process.Internals (
 #endif
     startDelegateControlC,
     endDelegateControlC,
+    stopDelegateControlC,
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
     pPrPr_disableITimers, c_execvpe,
     ignoreSignal, defaultSignal,