Fix AnnDotDot in module export
[ghc.git] / rts / win32 / ConsoleHandler.c
1 /*
2 * Console control handler support.
3 *
4 */
5 #include "Rts.h"
6 #include <windows.h>
7 #include "ConsoleHandler.h"
8 #include "Schedule.h"
9 #include "RtsUtils.h"
10 #include "AsyncIO.h"
11 #include "RtsSignals.h"
12
13 extern int stg_InstallConsoleEvent(int action, StgStablePtr *handler);
14
15 static BOOL WINAPI shutdown_handler(DWORD dwCtrlType);
16 static BOOL WINAPI generic_handler(DWORD dwCtrlType);
17
18 static rtsBool deliver_event = rtsTrue;
19 StgInt console_handler = STG_SIG_DFL;
20
21 #if !defined(THREADED_RTS)
22
23 static HANDLE hConsoleEvent = INVALID_HANDLE_VALUE;
24
25 #define N_PENDING_EVENTS 16
26 StgInt stg_pending_events = 0; /* number of undelivered events */
27 DWORD stg_pending_buf[N_PENDING_EVENTS]; /* their associated event numbers. */
28
29 #endif
30
31 /*
32 * Function: initUserSignals()
33 *
34 * Initialize the console handling substrate.
35 */
36 void
37 initUserSignals(void)
38 {
39 console_handler = STG_SIG_DFL;
40 #if !defined (THREADED_RTS)
41 stg_pending_events = 0;
42 if (hConsoleEvent == INVALID_HANDLE_VALUE) {
43 hConsoleEvent =
44 CreateEvent ( NULL, /* default security attributes */
45 TRUE, /* manual-reset event */
46 FALSE, /* initially non-signalled */
47 NULL); /* no name */
48 }
49 #endif
50 return;
51 }
52
53 void
54 freeSignalHandlers(void) {
55 /* Do nothing */
56 }
57
58 /* Seems to be a bit of an orphan...where used? */
59 void
60 finiUserSignals(void)
61 {
62 #if !defined (THREADED_RTS)
63 if (hConsoleEvent != INVALID_HANDLE_VALUE) {
64 CloseHandle(hConsoleEvent);
65 }
66 #endif
67 }
68
69 /*
70 * Function: shutdown_handler()
71 *
72 * Local function that performs the default handling of Ctrl+C kind
73 * events; gently shutting down the RTS
74 *
75 * To repeat Signals.c remark -- user code may choose to override the
76 * default handler. Which is fine, assuming they put back the default
77 * handler when/if they de-install the custom handler.
78 *
79 */
80 static BOOL WINAPI shutdown_handler(DWORD dwCtrlType)
81 {
82 switch (dwCtrlType) {
83
84 case CTRL_CLOSE_EVENT:
85 /* see generic_handler() comment re: this event */
86 return FALSE;
87 case CTRL_C_EVENT:
88 case CTRL_BREAK_EVENT:
89
90 // If we're already trying to interrupt the RTS, terminate with
91 // extreme prejudice. So the first ^C tries to exit the program
92 // cleanly, and the second one just kills it.
93 if (sched_state >= SCHED_INTERRUPTING) {
94 stg_exit(EXIT_INTERRUPTED);
95 } else {
96 interruptStgRts();
97 }
98 return TRUE;
99
100 /* shutdown + logoff events are not handled here. */
101 default:
102 return FALSE;
103 }
104 }
105
106
107 /*
108 * Function: initDefaultHandlers()
109 *
110 * Install any default signal/console handlers. Currently we install a
111 * Ctrl+C handler that shuts down the RTS in an orderly manner.
112 */
113 void initDefaultHandlers(void)
114 {
115 if ( !SetConsoleCtrlHandler(shutdown_handler, TRUE) ) {
116 errorBelch("warning: failed to install default console handler");
117 }
118 }
119
120 void resetDefaultHandlers(void)
121 {
122 if ( !SetConsoleCtrlHandler(shutdown_handler, FALSE) ) {
123 errorBelch("warning: failed to uninstall default console handler");
124 }
125 }
126
127 /*
128 * Function: blockUserSignals()
129 *
130 * Temporarily block the delivery of further console events. Needed to
131 * avoid race conditions when GCing the stack of outstanding handlers or
132 * when emptying the stack by running the handlers.
133 *
134 */
135 void
136 blockUserSignals(void)
137 {
138 deliver_event = rtsFalse;
139 }
140
141
142 /*
143 * Function: unblockUserSignals()
144 *
145 * The inverse of blockUserSignals(); re-enable the deliver of console events.
146 */
147 void
148 unblockUserSignals(void)
149 {
150 deliver_event = rtsTrue;
151 }
152
153
154 /*
155 * Function: awaitUserSignals()
156 *
157 * Wait for the next console event. Currently a NOP (returns immediately.)
158 */
159 void awaitUserSignals(void)
160 {
161 return;
162 }
163
164
165 #if !defined (THREADED_RTS)
166 /*
167 * Function: startSignalHandlers()
168 *
169 * Run the handlers associated with the stacked up console events. Console
170 * event delivery is blocked for the duration of this call.
171 */
172 void startSignalHandlers(Capability *cap)
173 {
174 StgStablePtr handler;
175
176 if (console_handler < 0) {
177 return;
178 }
179
180 blockUserSignals();
181 ACQUIRE_LOCK(&sched_mutex);
182
183 handler = deRefStablePtr((StgStablePtr)console_handler);
184 while (stg_pending_events > 0) {
185 stg_pending_events--;
186 scheduleThread(cap,
187 createIOThread(cap,
188 RtsFlags.GcFlags.initialStkSize,
189 rts_apply(cap,
190 (StgClosure *)handler,
191 rts_mkInt(cap,
192 stg_pending_buf[stg_pending_events]))));
193 }
194
195 RELEASE_LOCK(&sched_mutex);
196 unblockUserSignals();
197 }
198 #endif /* !THREADED_RTS */
199
200 /*
201 * Function: markSignalHandlers()
202 *
203 * Evacuate the handler stack. _Assumes_ that console event delivery
204 * has already been blocked.
205 */
206 void markSignalHandlers (evac_fn evac STG_UNUSED, void *user STG_UNUSED)
207 {
208 // nothing to mark; the console handler is a StablePtr which is
209 // already treated as a root by the GC.
210 }
211
212
213 /*
214 * Function: generic_handler()
215 *
216 * Local function which handles incoming console event (done in a separate
217 * OS thread), recording the event in stg_pending_events.
218 */
219 static BOOL WINAPI generic_handler(DWORD dwCtrlType)
220 {
221 /* Ultra-simple -- up the counter + signal a switch. */
222 switch(dwCtrlType) {
223 case CTRL_CLOSE_EVENT:
224 /* Don't support the delivery of this event; if we
225 * indicate that we've handled it here and the Haskell handler
226 * doesn't take proper action (e.g., terminate the OS process),
227 * the user of the app will be unable to kill/close it. Not
228 * good, so disable the delivery for now.
229 */
230 return FALSE;
231 default:
232 if (!deliver_event) return TRUE;
233
234 #if defined(THREADED_RTS)
235 sendIOManagerEvent((StgWord8) ((dwCtrlType<<1) | 1));
236 #else
237 if ( stg_pending_events < N_PENDING_EVENTS ) {
238 stg_pending_buf[stg_pending_events] = dwCtrlType;
239 stg_pending_events++;
240 }
241
242 // we need to wake up awaitEvent()
243 abandonRequestWait();
244 #endif
245 return TRUE;
246 }
247 }
248
249
250 /*
251 * Function: rts_InstallConsoleEvent()
252 *
253 * Install/remove a console event handler.
254 */
255 int
256 rts_InstallConsoleEvent(int action, StgStablePtr *handler)
257 {
258 StgInt previous_hdlr = console_handler;
259
260 switch (action) {
261 case STG_SIG_IGN:
262 console_handler = STG_SIG_IGN;
263 if ( !SetConsoleCtrlHandler(NULL, TRUE) ) {
264 errorBelch("warning: unable to ignore console events");
265 }
266 break;
267 case STG_SIG_DFL:
268 console_handler = STG_SIG_IGN;
269 if ( !SetConsoleCtrlHandler(NULL, FALSE) ) {
270 errorBelch("warning: unable to restore default console event "
271 "handling");
272 }
273 break;
274 case STG_SIG_HAN:
275 #ifdef THREADED_RTS
276 // handler is stored in an MVar in the threaded RTS
277 console_handler = STG_SIG_HAN;
278 #else
279 console_handler = (StgInt)*handler;
280 #endif
281 if (previous_hdlr < 0 || previous_hdlr == STG_SIG_HAN) {
282 /* Only install generic_handler() once */
283 if ( !SetConsoleCtrlHandler(generic_handler, TRUE) ) {
284 errorBelch("warning: unable to install console event handler");
285 }
286 }
287 break;
288 }
289
290 if (previous_hdlr == STG_SIG_DFL ||
291 previous_hdlr == STG_SIG_IGN ||
292 previous_hdlr == STG_SIG_HAN) {
293 return previous_hdlr;
294 } else {
295 if (handler != NULL) {
296 *handler = (StgStablePtr)previous_hdlr;
297 }
298 return STG_SIG_HAN;
299 }
300 }
301
302 /*
303 * Function: rts_HandledConsoleEvent()
304 *
305 * Signal that a Haskell console event handler has completed its run.
306 * The explicit notification that a Haskell handler has completed is
307 * required to better handle the delivery of Ctrl-C/Break events whilst
308 * an async worker thread is handling a read request on stdin. The
309 * Win32 console implementation will abort such a read request when Ctrl-C
310 * is delivered. That leaves the worker thread in a bind: should it
311 * abandon the request (the Haskell thread reading from stdin has been
312 * thrown an exception to signal the delivery of Ctrl-C & hence have
313 * aborted the I/O request) or simply ignore the aborted read and retry?
314 * (the Haskell thread reading from stdin isn't concerned with the
315 * delivery and handling of Ctrl-C.) With both scenarios being
316 * possible, the worker thread needs to be told -- that is, did the
317 * console event handler cause the IO request to be abandoned?
318 *
319 */
320 void
321 rts_ConsoleHandlerDone (int ev USED_IF_NOT_THREADS)
322 {
323 #if !defined(THREADED_RTS)
324 if ( (DWORD)ev == CTRL_BREAK_EVENT ||
325 (DWORD)ev == CTRL_C_EVENT ) {
326 /* only these two cause stdin system calls to abort.. */
327 SetEvent(hConsoleEvent); /* event is manual-reset */
328 Sleep(0); /* yield */
329 ResetEvent(hConsoleEvent); /* turn it back off again */
330 // SDM: yeuch, this can't possibly work reliably.
331 // I'm not having it in THREADED_RTS.
332 }
333 #endif
334 }
335
336 #if !defined(THREADED_RTS)
337 /*
338 * Function: rts_waitConsoleHandlerCompletion()
339 *
340 * Esoteric entry point used by worker thread that got woken
341 * up as part Ctrl-C delivery.
342 */
343 int
344 rts_waitConsoleHandlerCompletion()
345 {
346 /* As long as the worker doesn't need to do a multiple wait,
347 * let's keep this HANDLE private to this 'module'.
348 */
349 return (WaitForSingleObject(hConsoleEvent, INFINITE) == WAIT_OBJECT_0);
350 }
351 #endif