diff options
| -rw-r--r-- | includes/RtsAPI.h | 4 | ||||
| -rw-r--r-- | rts/Prelude.h | 2 | ||||
| -rw-r--r-- | rts/RtsAPI.c | 29 | ||||
| -rw-r--r-- | rts/RtsSymbols.c | 1 | ||||
| -rw-r--r-- | rts/Schedule.c | 5 | ||||
| -rw-r--r-- | rts/package.conf.in | 2 | ||||
| -rw-r--r-- | testsuite/tests/rts/T12903.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/rts/T12903.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/rts/all.T | 1 |
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, ['']) |