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

9 files changed, 54 insertions, 1 deletions

diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 3b6e1dc117..4dccb84fd2 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -282,6 +282,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 16881eb423..0186b5092b 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -52,6 +52,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_con_info);
 PRELUDE_INFO(ghczmprim_GHCziTypes_Izh_con_info);
@@ -84,6 +85,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 f009de7b64..2ca5dc437f 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -461,6 +461,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 60ffedbfc1..e50159642d 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -666,6 +666,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 2c862af848..49687b577a 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -2103,7 +2103,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 17d579fc7b..1da44a4cd1 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -104,6 +104,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"
@@ -195,6 +196,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 0000000000..ddaf8b97e8
--- /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 0000000000..cad99e1222
--- /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 9c55b21341..f9c4b8ee6e 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -375,4 +375,5 @@ test('numa001', [ extra_run_opts('8'), extra_ways(['debug_numa']) ]
 test('T12497', [ unless(opsys('mingw32'), skip)
                ],
                run_command, ['$MAKE -s --no-print-directory T12497'])
+test('T12903', [ when(opsys('mingw32'), skip)], compile_and_run, [''])