diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 4748060deea161ce1d1c8de97fe596213095f90a..0e29c63b54a8834757bf9588bfb42847282fecd6 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 ae1e9cb2662427955a723ec30520b515d5248527..444aa469ab27b50868f5d6e3017579cda397b4e7 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 c64d8af2e4bc0374f846d0fbbde5940a8f76140a..47f6c93942ad0ce81ad4b862525cacbbb64bebee 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -459,6 +459,35 @@ void rts_evalIO (/* inout */ Capability **cap,
scheduleWaitThread(tso,ret,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
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index fec5cfc0564fbe78889e2096c3b2c62fd417539c..44b6591c35d58aaf233c1ef4dcc3703d289df584 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 1f42e42417c95e9e455c99d35581b4db45f7f18a..33599d0abb7e6d52e2c9938a57f2477fa220c542 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 c0256bb028d9efe22503ef718d86eb3bea2ae50a..e328be7b613be58296bec8c5cdd38403f7880984 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 0000000000000000000000000000000000000000..ddaf8b97e8adb771b51c8e78d7c921d47a7a8b04
--- /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 0000000000000000000000000000000000000000..cad99e12229a1283e99e507e864f2ed1b7fe93c5
--- /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 f7d518c311032fb6bc39ac2e799da5b54ee1e5b5..d889276f1ec6c90e974ad075061f91933cb22f36 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, [''])
+