From fb0f4cf66f3fc7590821e6688440bf86c25aced1 Mon Sep 17 00:00:00 2001
From: Alexander Vershilov <alexander.vershilov@gmail.com>
Date: Fri, 2 Dec 2016 14:32:48 -0500
Subject: [PATCH] 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)
---
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(-)
create mode 100644 testsuite/tests/rts/T12903.hs
create mode 100644 testsuite/tests/rts/T12903.stdout
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index 4748060deea1..0e29c63b54a8 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 ae1e9cb26624..444aa469ab27 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 c64d8af2e4bc..47f6c93942ad 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 fec5cfc0564f..44b6591c35d5 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 1f42e42417c9..33599d0abb7e 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 c0256bb028d9..e328be7b613b 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 000000000000..ddaf8b97e8ad
--- /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 000000000000..cad99e12229a
--- /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 f7d518c31103..d889276f1ec6 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, [''])
+
--
GitLab