fix haddock submodule pointer
[ghc-hetmet.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 sep OS thread),
217  * 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 handling");
271         }
272         break;
273     case STG_SIG_HAN:
274 #ifdef THREADED_RTS
275         // handler is stored in an MVar in the threaded RTS
276         console_handler = STG_SIG_HAN;
277 #else
278         console_handler = (StgInt)*handler;
279 #endif
280         if (previous_hdlr < 0 || previous_hdlr == STG_SIG_HAN) {
281           /* Only install generic_handler() once */
282           if ( !SetConsoleCtrlHandler(generic_handler, TRUE) ) {
283             errorBelch("warning: unable to install console event handler");
284           }
285         }
286         break;
287     }
288     
289     if (previous_hdlr == STG_SIG_DFL || 
290         previous_hdlr == STG_SIG_IGN ||
291         previous_hdlr == STG_SIG_HAN) {
292         return previous_hdlr;
293     } else {
294         if (handler != NULL) {
295             *handler = (StgStablePtr)previous_hdlr;
296         }
297         return STG_SIG_HAN;
298     }
299 }
300
301 /*
302  * Function: rts_HandledConsoleEvent()
303  *
304  * Signal that a Haskell console event handler has completed its run.
305  * The explicit notification that a Haskell handler has completed is 
306  * required to better handle the delivery of Ctrl-C/Break events whilst
307  * an async worker thread is handling a read request on stdin. The 
308  * Win32 console implementation will abort such a read request when Ctrl-C
309  * is delivered. That leaves the worker thread in a bind: should it 
310  * abandon the request (the Haskell thread reading from stdin has been 
311  * thrown an exception to signal the delivery of Ctrl-C & hence have 
312  * aborted the I/O request) or simply ignore the aborted read and retry?
313  * (the Haskell thread reading from stdin isn't concerned with the
314  * delivery and handling of Ctrl-C.) With both scenarios being
315  * possible, the worker thread needs to be told -- that is, did the
316  * console event handler cause the IO request to be abandoned? 
317  *
318  */
319 void
320 rts_ConsoleHandlerDone (int ev USED_IF_NOT_THREADS)
321 {
322 #if !defined(THREADED_RTS)
323     if ( (DWORD)ev == CTRL_BREAK_EVENT ||
324          (DWORD)ev == CTRL_C_EVENT ) {
325         /* only these two cause stdin system calls to abort.. */
326         SetEvent(hConsoleEvent); /* event is manual-reset */
327         Sleep(0); /* yield */
328         ResetEvent(hConsoleEvent); /* turn it back off again */
329         // SDM: yeuch, this can't possibly work reliably.
330         // I'm not having it in THREADED_RTS.
331     }
332 #endif
333 }
334
335 #if !defined(THREADED_RTS)
336 /*
337  * Function: rts_waitConsoleHandlerCompletion()
338  *
339  * Esoteric entry point used by worker thread that got woken
340  * up as part Ctrl-C delivery.
341  */
342 int
343 rts_waitConsoleHandlerCompletion()
344 {
345     /* As long as the worker doesn't need to do a multiple wait,
346      * let's keep this HANDLE private to this 'module'.
347      */
348     return (WaitForSingleObject(hConsoleEvent, INFINITE) == WAIT_OBJECT_0);
349 }
350 #endif