Commit 895a131f authored by Alexander Vershilov's avatar Alexander Vershilov Committed by Ben Gamari
Browse files

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
parent f46369b8
......@@ -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);
......
......@@ -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)
......
......@@ -460,6 +460,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
......
......@@ -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) \
......
......@@ -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);
......
......@@ -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"
......
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
......@@ -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, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment