#include "Schedule.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
-#include "StablePriv.h"
+#include "AsyncIO.h"
+#include "RtsSignals.h"
extern int stg_InstallConsoleEvent(int action, StgStablePtr *handler);
static rtsBool deliver_event = rtsTrue;
static StgInt console_handler = STG_SIG_DFL;
+static HANDLE hConsoleEvent = INVALID_HANDLE_VALUE;
+
#define N_PENDING_EVENTS 16
StgInt stg_pending_events = 0; /* number of undelivered events */
DWORD stg_pending_buf[N_PENDING_EVENTS]; /* their associated event numbers. */
{
stg_pending_events = 0;
console_handler = STG_SIG_DFL;
+ if (hConsoleEvent == INVALID_HANDLE_VALUE) {
+ hConsoleEvent =
+ CreateEvent ( NULL, /* default security attributes */
+ TRUE, /* manual-reset event */
+ FALSE, /* initially non-signalled */
+ NULL); /* no name */
+ }
return;
}
{
switch (dwCtrlType) {
+ case CTRL_CLOSE_EVENT:
+ /* see generic_handler() comment re: this event */
+ return FALSE;
case CTRL_C_EVENT:
case CTRL_BREAK_EVENT:
- case CTRL_CLOSE_EVENT:
// If we're already trying to interrupt the RTS, terminate with
// extreme prejudice. So the first ^C tries to exit the program
// cleanly, and the second one just kills it.
- if (interrupted) {
+ if (sched_state >= SCHED_INTERRUPTING) {
stg_exit(EXIT_INTERRUPTED);
} else {
interruptStgRts();
+ /* Cheesy pulsing of an event to wake up a waiting RTS thread, if any */
+ abandonRequestWait();
+ resetAbandonRequestWait();
}
return TRUE;
void initDefaultHandlers(void)
{
if ( !SetConsoleCtrlHandler(shutdown_handler, TRUE) ) {
- prog_belch("warning: failed to install default console handler");
+ errorBelch("warning: failed to install default console handler");
}
}
* Run the handlers associated with the stacked up console events. Console
* event delivery is blocked for the duration of this call.
*/
-void startSignalHandlers(void)
+void startSignalHandlers(Capability *cap)
{
StgStablePtr handler;
if (console_handler < 0) {
return;
}
+
blockUserSignals();
+ ACQUIRE_LOCK(&sched_mutex);
handler = deRefStablePtr((StgStablePtr)console_handler);
while (stg_pending_events > 0) {
stg_pending_events--;
- scheduleThread(
- createIOThread(RtsFlags.GcFlags.initialStkSize,
- rts_apply((StgClosure *)handler,
- rts_mkInt(stg_pending_buf[stg_pending_events]))));
+ scheduleThread(cap,
+ createIOThread(cap,
+ RtsFlags.GcFlags.initialStkSize,
+ rts_apply(cap,
+ (StgClosure *)handler,
+ rts_mkInt(cap,
+ stg_pending_buf[stg_pending_events]))));
}
+
+ RELEASE_LOCK(&sched_mutex);
unblockUserSignals();
}
-
/*
* Function: markSignalHandlers()
*
}
-/*
- * Function: handleSignalsInThisThread()
- *
- * Have current (OS) thread assume responsibility of handling console events/signals.
- * Currently not used (by the console event handling code.)
- */
-void handleSignalsInThisThread(void)
-{
- return;
-}
-
/*
* Function: generic_handler()
*
*/
static BOOL WINAPI generic_handler(DWORD dwCtrlType)
{
+ ACQUIRE_LOCK(&sched_mutex);
+
/* Ultra-simple -- up the counter + signal a switch. */
- if ( stg_pending_events < N_PENDING_EVENTS ) {
- stg_pending_buf[stg_pending_events] = dwCtrlType;
- stg_pending_events++;
+ switch(dwCtrlType) {
+ case CTRL_CLOSE_EVENT:
+ /* Don't support the delivery of this event; if we
+ * indicate that we've handled it here and the Haskell handler
+ * doesn't take proper action (e.g., terminate the OS process),
+ * the user of the app will be unable to kill/close it. Not
+ * good, so disable the delivery for now.
+ */
+ return FALSE;
+ default:
+ if (!deliver_event) return TRUE;
+
+ if ( stg_pending_events < N_PENDING_EVENTS ) {
+ stg_pending_buf[stg_pending_events] = dwCtrlType;
+ stg_pending_events++;
+ }
+ /* Cheesy pulsing of an event to wake up a waiting RTS thread, if any */
+ abandonRequestWait();
+ resetAbandonRequestWait();
+ return TRUE;
}
- context_switch = 1;
- return TRUE;
+
+ RELEASE_LOCK(&sched_mutex);
}
/*
- * Function: stg_InstallConsoleEvent()
+ * Function: rts_InstallConsoleEvent()
*
* Install/remove a console event handler.
*/
int
-stg_InstallConsoleEvent(int action, StgStablePtr *handler)
+rts_InstallConsoleEvent(int action, StgStablePtr *handler)
{
StgInt previous_hdlr = console_handler;
case STG_SIG_IGN:
console_handler = STG_SIG_IGN;
if ( !SetConsoleCtrlHandler(NULL, TRUE) ) {
- prog_belch("warning: unable to ignore console events");
+ errorBelch("warning: unable to ignore console events");
}
break;
case STG_SIG_DFL:
console_handler = STG_SIG_IGN;
if ( !SetConsoleCtrlHandler(NULL, FALSE) ) {
- prog_belch("warning: unable to restore default console event handling");
+ errorBelch("warning: unable to restore default console event handling");
}
break;
case STG_SIG_HAN:
if ( previous_hdlr < 0 ) {
/* Only install generic_handler() once */
if ( !SetConsoleCtrlHandler(generic_handler, TRUE) ) {
- prog_belch("warning: unable to install console event handler");
+ errorBelch("warning: unable to install console event handler");
}
}
break;
return STG_SIG_HAN;
}
}
+
+/*
+ * Function: rts_HandledConsoleEvent()
+ *
+ * Signal that a Haskell console event handler has completed its run.
+ * The explicit notification that a Haskell handler has completed is
+ * required to better handle the delivery of Ctrl-C/Break events whilst
+ * an async worker thread is handling a read request on stdin. The
+ * Win32 console implementation will abort such a read request when Ctrl-C
+ * is delivered. That leaves the worker thread in a bind: should it
+ * abandon the request (the Haskell thread reading from stdin has been
+ * thrown an exception to signal the delivery of Ctrl-C & hence have
+ * aborted the I/O request) or simply ignore the aborted read and retry?
+ * (the Haskell thread reading from stdin isn't concerned with the
+ * delivery and handling of Ctrl-C.) With both scenarios being
+ * possible, the worker thread needs to be told -- that is, did the
+ * console event handler cause the IO request to be abandoned?
+ *
+ */
+void
+rts_ConsoleHandlerDone(int ev)
+{
+ if ( (DWORD)ev == CTRL_BREAK_EVENT ||
+ (DWORD)ev == CTRL_C_EVENT ) {
+ /* only these two cause stdin system calls to abort.. */
+ SetEvent(hConsoleEvent); /* event is manual-reset */
+ Sleep(0); /* yield */
+ ResetEvent(hConsoleEvent); /* turn it back off again */
+ }
+}
+
+/*
+ * Function: rts_waitConsoleHandlerCompletion()
+ *
+ * Esoteric entry point used by worker thread that got woken
+ * up as part Ctrl-C delivery.
+ */
+int
+rts_waitConsoleHandlerCompletion()
+{
+ /* As long as the worker doesn't need to do a multiple wait,
+ * let's keep this HANDLE private to this 'module'.
+ */
+ return (WaitForSingleObject(hConsoleEvent, INFINITE) == WAIT_OBJECT_0);
+}
projects / ghc-hetmet.git / blobdiff