[commit: ghc] ghc-7.10: Fix #10017 (ddd95c0)

[git at git.haskell.org]

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

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/ddd95c0b575da33447c078a8791d3c4f2edec9b7/ghc

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

commit ddd95c0b575da33447c078a8791d3c4f2edec9b7
Author: Andreas Voellmy <andreas.voellmy at gmail.com>
Date:   Mon Feb 2 10:50:52 2015 -0500

    Fix #10017
    
    Summary:
    In the threaded RTS, a signal is delivered from the RTS to Haskell
    user code by writing to file that one of the IO managers watches (via
    an instance of GHC.Event.Control.Control). When the IO manager
    receives the signal, it calls GHC.Conc.Signal.runHandlers to invoke
    Haskell signal handler. In the move from a single IO manager to one IO
    manager per capability, the behavior was (wrongly) extended so that a
    signal is delivered to every event manager (see #9423), each of which
    invoke Haskell signal handlers, leading to multiple invocations of
    Haskell signal handlers for a single signal. This change fixes this
    problem by having the RTS (in generic_handler()) notify only the
    Control instance used by the TimerManager, rather than all the
    per-capability IO managers.
    
    Reviewers: austin, hvr, simonmar, Mikolaj
    
    Reviewed By: simonmar, Mikolaj
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D641
    
    (cherry picked from commit 92c93544939199f6ef758e1658149a971d4437c9)


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

ddd95c0b575da33447c078a8791d3c4f2edec9b7
 libraries/base/GHC/Event/Manager.hs |  3 +--
 rts/posix/Signals.c                 | 12 ------------
 testsuite/tests/rts/T10017.hs       | 11 +++++++++++
 testsuite/tests/rts/T10017.stdout   |  1 +
 testsuite/tests/rts/all.T           |  2 ++
 5 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs
index eeda1c8..11b01ad 100644
--- a/libraries/base/GHC/Event/Manager.hs
+++ b/libraries/base/GHC/Event/Manager.hs
@@ -72,7 +72,6 @@ import Data.Maybe (maybe)
 import Data.OldList (partition)
 import GHC.Arr (Array, (!), listArray)
 import GHC.Base
-import GHC.Conc.Signal (runHandlers)
 import GHC.Conc.Sync (yield)
 import GHC.List (filter, replicate)
 import GHC.Num (Num(..))
@@ -163,7 +162,7 @@ handleControlEvent mgr fd _evt = do
   case msg of
     CMsgWakeup      -> return ()
     CMsgDie         -> writeIORef (emState mgr) Finished
-    CMsgSignal fp s -> runHandlers fp s
+    _               -> return ()
 
 newDefaultBackend :: IO Backend
 #if defined(HAVE_KQUEUE)
diff --git a/rts/posix/Signals.c b/rts/posix/Signals.c
index 44bd0b6..5fbb917 100644
--- a/rts/posix/Signals.c
+++ b/rts/posix/Signals.c
@@ -251,18 +251,6 @@ generic_handler(int sig USED_IF_THREADS,
         }
     }
 
-    nat i;
-    int fd;
-    for (i=0; i < n_capabilities; i++) {
-        fd = capabilities[i]->io_manager_control_wr_fd;
-        if (0 <= fd) {
-            r = write(fd, buf, sizeof(siginfo_t)+1);
-            if (r == -1 && errno == EAGAIN) {
-                errorBelch("lost signal due to full pipe: %d\n", sig);
-            }
-        }
-    }
-
     // If the IO manager hasn't told us what the FD of the write end
     // of its pipe is, there's not much we can do here, so just ignore
     // the signal..
diff --git a/testsuite/tests/rts/T10017.hs b/testsuite/tests/rts/T10017.hs
new file mode 100644
index 0000000..ed34841
--- /dev/null
+++ b/testsuite/tests/rts/T10017.hs
@@ -0,0 +1,11 @@
+import Control.Concurrent
+import System.Posix.Signals
+
+main :: IO ()
+main = do
+    _ <- flip (installHandler sig) Nothing $ Catch $
+        putStrLn $ "Received my signal"
+    raiseSignal sig
+    threadDelay 100000
+  where
+    sig = sigUSR2
diff --git a/testsuite/tests/rts/T10017.stdout b/testsuite/tests/rts/T10017.stdout
new file mode 100644
index 0000000..f138924
--- /dev/null
+++ b/testsuite/tests/rts/T10017.stdout
@@ -0,0 +1 @@
+Received my signal
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 89f1da8..88c354f 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -238,6 +238,8 @@ test('T9045', [ omit_ways(['ghci']), extra_run_opts('10000 +RTS -A8k -RTS') ], c
 # with the non-threaded one.
 test('T9078', [ omit_ways(threaded_ways) ], compile_and_run, ['-with-rtsopts="-DS" -debug'])
 
+test('T10017', [ only_ways(threaded_ways), extra_run_opts('+RTS -N2 -RTS') ], compile_and_run, [''])
+
 test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
                  # this needs runtime infrastructure to do in ghci:
                  #  '-rdynamic' ghc, load modules only via dlopen(RTLD_BLOBAL) and more.