[commit: ghc] ghc-8.0: Install toplevel handler inside fork. (fb0f4cf)

git at git.haskell.org git at git.haskell.org
Fri Dec 2 21:09:26 UTC 2016


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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/fb0f4cf66f3fc7590821e6688440bf86c25aced1/ghc

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

commit fb0f4cf66f3fc7590821e6688440bf86c25aced1
Author: Alexander Vershilov <alexander.vershilov at gmail.com>
Date:   Fri Dec 2 14:32:48 2016 -0500

    Install toplevel handler inside fork.
    
    When rts is forked it doesn't update toplevel handler, so UserInterrupt
    exception is sent to Thread1 that doesn't exist in forked process.
    
    We install toplevel handler when fork so signal will be delivered to the
    new main thread.
    
    Fixes #12903
    
    Reviewers: simonmar, austin, erikd, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2770
    
    GHC Trac Issues: #12903
    
    (cherry picked from commit 895a131f6e56847d9ebca2e9bfe19a3189e49d72)


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

fb0f4cf66f3fc7590821e6688440bf86c25aced1
 includes/RtsAPI.h                 |  4 ++++
 rts/Prelude.h                     |  2 ++
 rts/RtsAPI.c                      | 29 +++++++++++++++++++++++++++++
 rts/RtsSymbols.c                  |  1 +
 rts/Schedule.c                    |  5 ++++-
 rts/package.conf.in               |  2 ++
 testsuite/tests/rts/T12903.hs     | 10 ++++++++++
 testsuite/tests/rts/T12903.stdout |  1 +
 testsuite/tests/rts/all.T         |  2 ++
 9 files changed, 55 insertions(+), 1 deletion(-)

diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 4748060..0e29c63 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -245,6 +245,10 @@ void rts_evalIO (/* inout */ Capability **,
                  /* in    */ HaskellObj p,
                  /* out */   HaskellObj *ret);
 
+void rts_evalStableIOMain (/* inout */ Capability **,
+                           /* in    */ HsStablePtr s,
+                           /* out */   HsStablePtr *ret);
+
 void rts_evalStableIO (/* inout */ Capability **,
                        /* in    */ HsStablePtr s,
                        /* out */   HsStablePtr *ret);
diff --git a/rts/Prelude.h b/rts/Prelude.h
index ae1e9cb..444aa46 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -51,6 +51,7 @@ PRELUDE_CLOSURE(base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure);
 PRELUDE_CLOSURE(base_GHCziConcziSignal_runHandlersPtr_closure);
 
 PRELUDE_CLOSURE(base_GHCziTopHandler_flushStdHandles_closure);
+PRELUDE_CLOSURE(base_GHCziTopHandler_runMainIO_closure);
 
 PRELUDE_INFO(ghczmprim_GHCziTypes_Czh_static_info);
 PRELUDE_INFO(ghczmprim_GHCziTypes_Izh_static_info);
@@ -99,6 +100,7 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define runHandlersPtr_closure       DLL_IMPORT_DATA_REF(base_GHCziConcziSignal_runHandlersPtr_closure)
 
 #define flushStdHandles_closure   DLL_IMPORT_DATA_REF(base_GHCziTopHandler_flushStdHandles_closure)
+#define runMainIO_closure   DLL_IMPORT_DATA_REF(base_GHCziTopHandler_runMainIO_closure)
 
 #define stackOverflow_closure     DLL_IMPORT_DATA_REF(base_GHCziIOziException_stackOverflow_closure)
 #define heapOverflow_closure      DLL_IMPORT_DATA_REF(base_GHCziIOziException_heapOverflow_closure)
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index c64d8af..47f6c93 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -460,6 +460,35 @@ void rts_evalIO (/* inout */ Capability **cap,
 }
 
 /*
+ * rts_evalStableIOMain() is suitable for calling main Haskell thread
+ * stored in (StablePtr (IO a)) it calls rts_evalStableIO but wraps
+ * function in GHC.TopHandler.runMainIO that installs top_handlers.
+ * See Trac #12903.
+ */
+void rts_evalStableIOMain(/* inout */ Capability **cap,
+                          /* in    */ HsStablePtr s,
+                          /* out   */ HsStablePtr *ret)
+{
+    StgTSO* tso;
+    StgClosure *p, *r, *w;
+    SchedulerStatus stat;
+
+    p = (StgClosure *)deRefStablePtr(s);
+    w = rts_apply(*cap, &base_GHCziTopHandler_runMainIO_closure, p);
+    tso = createStrictIOThread(*cap, RtsFlags.GcFlags.initialStkSize, w);
+    // async exceptions are always blocked by default in the created
+    // thread.  See #1048.
+    tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+    scheduleWaitThread(tso,&r,cap);
+    stat = rts_getSchedStatus(*cap);
+
+    if (stat == Success && ret != NULL) {
+        ASSERT(r != NULL);
+        *ret = getStablePtr((StgPtr)r);
+    }
+}
+
+/*
  * rts_evalStableIO() is suitable for calling from Haskell.  It
  * evaluates a value of the form (StablePtr (IO a)), forcing the
  * action's result to WHNF before returning.  The result is returned
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index fec5cfc..44b6591 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -647,6 +647,7 @@
       SymI_HasProto(rts_eval)                                           \
       SymI_HasProto(rts_evalIO)                                         \
       SymI_HasProto(rts_evalLazyIO)                                     \
+      SymI_HasProto(rts_evalStableIOMain)                               \
       SymI_HasProto(rts_evalStableIO)                                   \
       SymI_HasProto(rts_eval_)                                          \
       SymI_HasProto(rts_getBool)                                        \
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 1f42e42..33599d0 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -2078,7 +2078,10 @@ forkProcess(HsStablePtr *entry
         ioManagerStartCap(&cap);
 #endif
 
-        rts_evalStableIO(&cap, entry, NULL);  // run the action
+        // Install toplevel exception handlers, so interruption
+        // signal will be sent to the main thread.
+        // See Trac #12903
+        rts_evalStableIOMain(&cap, entry, NULL);  // run the action
         rts_checkSchedStatus("forkProcess",cap);
 
         rts_unlock(cap);
diff --git a/rts/package.conf.in b/rts/package.conf.in
index c0256bb..e328be7 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -106,6 +106,7 @@ ld-options:
          , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure"
          , "-Wl,-u,_base_GHCziTopHandler_runIO_closure"
          , "-Wl,-u,_base_GHCziTopHandler_runNonIO_closure"
+         , "-Wl,-u,_base_GHCziTopHandler_runMainIO_closure"
          , "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
          , "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure"
          , "-Wl,-u,_base_GHCziConcziSync_runSparks_closure"
@@ -148,6 +149,7 @@ ld-options:
          , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure"
          , "-Wl,-u,base_GHCziTopHandler_runIO_closure"
          , "-Wl,-u,base_GHCziTopHandler_runNonIO_closure"
+         , "-Wl,-u,base_GHCziTopHandler_runMainIO_closure"
          , "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure"
          , "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure"
          , "-Wl,-u,base_GHCziConcziSync_runSparks_closure"
diff --git a/testsuite/tests/rts/T12903.hs b/testsuite/tests/rts/T12903.hs
new file mode 100644
index 0000000..ddaf8b9
--- /dev/null
+++ b/testsuite/tests/rts/T12903.hs
@@ -0,0 +1,10 @@
+import Control.Concurrent
+import Control.Exception
+import System.Posix
+
+main = do
+  pid <- forkProcess $ do
+           handle (\UserInterrupt{} -> putStrLn "caught")
+                  $ threadDelay 2000000
+  signalProcess sigINT pid
+  threadDelay 2000000
diff --git a/testsuite/tests/rts/T12903.stdout b/testsuite/tests/rts/T12903.stdout
new file mode 100644
index 0000000..cad99e1
--- /dev/null
+++ b/testsuite/tests/rts/T12903.stdout
@@ -0,0 +1 @@
+caught
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index f7d518c..d889276 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -345,3 +345,5 @@ test('T10296b', [only_ways('threaded2')], compile_and_run, [''])
 test('T12497', [ unless(opsys('mingw32'), skip)
                ],
                run_command, ['$MAKE -s --no-print-directory T12497'])
+test('T12903', [ when(opsys('mingw32'), skip)], compile_and_run, [''])
+



More information about the ghc-commits mailing list