Control.Exception.unblock wasn't unblocking exceptions
[ghc.git] / rts / Exception.cmm
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-2004
4  *
5  * Exception support
6  *
7  * This file is written in a subset of C--, extended with various
8  * features specific to GHC.  It is compiled by GHC directly.  For the
9  * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
10  *
11  * ---------------------------------------------------------------------------*/
12
13 #include "Cmm.h"
14 #include "RaiseAsync.h"
15
16 /* -----------------------------------------------------------------------------
17    Exception Primitives
18
19    A thread can request that asynchronous exceptions not be delivered
20    ("blocked") for the duration of an I/O computation.  The primitive
21    
22         blockAsyncExceptions# :: IO a -> IO a
23
24    is used for this purpose.  During a blocked section, asynchronous
25    exceptions may be unblocked again temporarily:
26
27         unblockAsyncExceptions# :: IO a -> IO a
28
29    Furthermore, asynchronous exceptions are blocked automatically during
30    the execution of an exception handler.  Both of these primitives
31    leave a continuation on the stack which reverts to the previous
32    state (blocked or unblocked) on exit.
33
34    A thread which wants to raise an exception in another thread (using
35    killThread#) must block until the target thread is ready to receive
36    it.  The action of unblocking exceptions in a thread will release all
37    the threads waiting to deliver exceptions to that thread.
38
39    NB. there's a bug in here.  If a thread is inside an
40    unsafePerformIO, and inside blockAsyncExceptions# (there is an
41    unblockAsyncExceptions_ret on the stack), and it is blocked in an
42    interruptible operation, and it receives an exception, then the
43    unsafePerformIO thunk will be updated with a stack object
44    containing the unblockAsyncExceptions_ret frame.  Later, when
45    someone else evaluates this thunk, the blocked exception state is
46    not restored, and the result is that unblockAsyncExceptions_ret
47    will attempt to unblock exceptions in the current thread, but it'll
48    find that the CurrentTSO->blocked_exceptions is NULL.  Hence, we
49    work around this by checking for NULL in awakenBlockedQueue().
50
51    -------------------------------------------------------------------------- */
52
53 INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
54                 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
55 {
56     // Not true: see comments above
57     // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) != NULL);
58
59     foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
60                                             CurrentTSO "ptr") [R1];
61
62     StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
63         ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
64
65 #ifdef REG_R1
66     Sp_adj(1);
67     jump %ENTRY_CODE(Sp(0));
68 #else
69     Sp(1) = Sp(0);
70     Sp_adj(1);
71     jump %ENTRY_CODE(Sp(1));
72 #endif
73 }
74
75 INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
76                 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
77 {
78     // Not true: see comments above
79     // ASSERT(StgTSO_blocked_exceptions(CurrentTSO) == NULL);
80
81     StgTSO_flags(CurrentTSO) = 
82         StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
83
84 #ifdef REG_R1
85     Sp_adj(1);
86     jump %ENTRY_CODE(Sp(0));
87 #else
88     Sp(1) = Sp(0);
89     Sp_adj(1);
90     jump %ENTRY_CODE(Sp(1));
91 #endif
92 }
93
94 blockAsyncExceptionszh_fast
95 {
96     /* Args: R1 :: IO a */
97     STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
98
99     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
100         
101         StgTSO_flags(CurrentTSO) = 
102            StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
103
104         /* avoid growing the stack unnecessarily */
105         if (Sp(0) == stg_blockAsyncExceptionszh_ret_info) {
106             Sp_adj(1);
107         } else {
108             Sp_adj(-1);
109             Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
110         }
111     }
112     TICK_UNKNOWN_CALL();
113     TICK_SLOW_CALL_v();
114     jump stg_ap_v_fast;
115 }
116
117 unblockAsyncExceptionszh_fast
118 {
119     /* Args: R1 :: IO a */
120     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
121
122     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
123         foreign "C" awakenBlockedExceptionQueue(MyCapability() "ptr", 
124                                                 CurrentTSO "ptr") [R1];
125
126         StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
127            ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
128
129         /* avoid growing the stack unnecessarily */
130         if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
131             Sp_adj(1);
132         } else {
133             Sp_adj(-1);
134             Sp(0) = stg_blockAsyncExceptionszh_ret_info;
135         }
136     }
137     TICK_UNKNOWN_CALL();
138     TICK_SLOW_CALL_v();
139     jump stg_ap_v_fast;
140 }
141
142
143 killThreadzh_fast
144 {
145     /* args: R1 = TSO to kill, R2 = Exception */
146
147     W_ why_blocked;
148     W_ target;
149     W_ exception;
150     
151     target = R1;
152     exception = R2;
153     
154     STK_CHK_GEN( WDS(3), R1_PTR & R2_PTR, killThreadzh_fast);
155
156     /* 
157      * We might have killed ourselves.  In which case, better be *very*
158      * careful.  If the exception killed us, then return to the scheduler.
159      * If the exception went to a catch frame, we'll just continue from
160      * the handler.
161      */
162     if (target == CurrentTSO) {
163         SAVE_THREAD_STATE();
164         /* ToDo: what if the current thread is blocking exceptions? */
165         foreign "C" throwToSingleThreaded(MyCapability() "ptr", 
166                                           target "ptr", exception "ptr")[R1,R2];
167         if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
168             R1 = ThreadFinished;
169             jump StgReturn;
170         } else {
171             LOAD_THREAD_STATE();
172             ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
173             jump %ENTRY_CODE(Sp(0));
174         }
175     } else {
176         W_ out;
177         W_ retcode;
178         out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w;
179         
180         retcode = foreign "C" throwTo(MyCapability() "ptr",
181                                       CurrentTSO "ptr",
182                                       target "ptr",
183                                       exception "ptr",
184                                       out "ptr") [R1,R2];
185         
186         switch [THROWTO_SUCCESS .. THROWTO_BLOCKED] (retcode) {
187
188         case THROWTO_SUCCESS: {
189             jump %ENTRY_CODE(Sp(0));
190         }
191
192         case THROWTO_BLOCKED: {
193             R3 = W_[out];
194             // we must block, and call throwToReleaseTarget() before returning
195             jump stg_block_throwto;
196         }
197         }
198     }
199 }
200
201 /* -----------------------------------------------------------------------------
202    Catch frames
203    -------------------------------------------------------------------------- */
204
205 #ifdef REG_R1
206 #define CATCH_FRAME_ENTRY_TEMPLATE(label,ret)   \
207    label                                        \
208    {                                            \
209       Sp = Sp + SIZEOF_StgCatchFrame;           \
210       jump ret;                                 \
211    }
212 #else
213 #define CATCH_FRAME_ENTRY_TEMPLATE(label,ret)   \
214    label                                        \
215    {                                            \
216       W_ rval;                                  \
217       rval = Sp(0);                             \
218       Sp = Sp + SIZEOF_StgCatchFrame;           \
219       Sp(0) = rval;                             \
220       jump ret;                                 \
221    }
222 #endif
223
224 #ifdef REG_R1
225 #define SP_OFF 0
226 #else
227 #define SP_OFF 1
228 #endif
229
230 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
231 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
232 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
233 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
234 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
235 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
236 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
237 CATCH_FRAME_ENTRY_TEMPLATE(stg_catch_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
238
239 #if MAX_VECTORED_RTN > 8
240 #error MAX_VECTORED_RTN has changed: please modify stg_catch_frame too.
241 #endif
242
243 #if defined(PROFILING)
244 #define CATCH_FRAME_BITMAP 7
245 #define CATCH_FRAME_WORDS  4
246 #else
247 #define CATCH_FRAME_BITMAP 1
248 #define CATCH_FRAME_WORDS  2
249 #endif
250
251 /* Catch frames are very similar to update frames, but when entering
252  * one we just pop the frame off the stack and perform the correct
253  * kind of return to the activation record underneath us on the stack.
254  */
255
256 INFO_TABLE_RET(stg_catch_frame,
257                CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
258                CATCH_FRAME,
259                stg_catch_frame_0_ret,
260                stg_catch_frame_1_ret,
261                stg_catch_frame_2_ret,
262                stg_catch_frame_3_ret,
263                stg_catch_frame_4_ret,
264                stg_catch_frame_5_ret,
265                stg_catch_frame_6_ret,
266                stg_catch_frame_7_ret)
267 CATCH_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
268
269 /* -----------------------------------------------------------------------------
270  * The catch infotable
271  *
272  * This should be exactly the same as would be generated by this STG code
273  *
274  * catch = {x,h} \n {} -> catch#{x,h}
275  *
276  * It is used in deleteThread when reverting blackholes.
277  * -------------------------------------------------------------------------- */
278
279 INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
280 {
281   R2 = StgClosure_payload(R1,1); /* h */
282   R1 = StgClosure_payload(R1,0); /* x */
283   jump catchzh_fast;
284 }
285
286 catchzh_fast
287 {
288     /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
289     STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, catchzh_fast);
290   
291     /* Set up the catch frame */
292     Sp = Sp - SIZEOF_StgCatchFrame;
293     SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
294     
295     StgCatchFrame_handler(Sp) = R2;
296     StgCatchFrame_exceptions_blocked(Sp) = TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX;
297     TICK_CATCHF_PUSHED();
298
299     /* Apply R1 to the realworld token */
300     TICK_UNKNOWN_CALL();
301     TICK_SLOW_CALL_v();
302     jump stg_ap_v_fast;
303 }
304
305 /* -----------------------------------------------------------------------------
306  * The raise infotable
307  * 
308  * This should be exactly the same as would be generated by this STG code
309  *
310  *   raise = {err} \n {} -> raise#{err}
311  *
312  * It is used in raisezh_fast to update thunks on the update list
313  * -------------------------------------------------------------------------- */
314
315 INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
316 {
317   R1 = StgThunk_payload(R1,0);
318   jump raisezh_fast;
319 }
320
321 raisezh_fast
322 {
323     W_ handler;
324     W_ raise_closure;
325     W_ frame_type;
326     /* args : R1 :: Exception */
327
328
329 #if defined(PROFILING)
330     /* Debugging tool: on raising an  exception, show where we are. */
331
332     /* ToDo: currently this is a hack.  Would be much better if
333      * the info was only displayed for an *uncaught* exception.
334      */
335     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
336       foreign "C" fprintCCS_stderr(W_[CCCS] "ptr");
337     }
338 #endif
339
340 retry_pop_stack:
341     StgTSO_sp(CurrentTSO) = Sp;
342     frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", R1 "ptr");
343     Sp = StgTSO_sp(CurrentTSO);
344     if (frame_type == ATOMICALLY_FRAME) {
345       /* The exception has reached the edge of a memory transaction.  Check that 
346        * the transaction is valid.  If not then perhaps the exception should
347        * not have been thrown: re-run the transaction */
348       W_ trec;
349       W_ r;
350       trec = StgTSO_trec(CurrentTSO);
351       r = foreign "C" stmValidateNestOfTransactions(trec "ptr");
352       foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
353       StgTSO_trec(CurrentTSO) = NO_TREC;
354       if (r != 0) {
355         // Transaction was valid: continue searching for a catch frame
356         Sp = Sp + SIZEOF_StgAtomicallyFrame;
357         goto retry_pop_stack;
358       } else {
359         // Transaction was not valid: we retry the exception (otherwise continue
360         // with a further call to raiseExceptionHelper)
361         "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
362         StgTSO_trec(CurrentTSO) = trec;
363         R1 = StgAtomicallyFrame_code(Sp);
364         jump stg_ap_v_fast;
365       }          
366     }
367
368     if (frame_type == STOP_FRAME) {
369         /*
370          * We've stripped the entire stack, the thread is now dead.
371          * We will leave the stack in a GC'able state, see the stg_stop_thread
372          * entry code in StgStartup.cmm.
373          */
374         Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
375                 + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
376         Sp(1) = R1;             /* save the exception */
377         Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
378         StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
379         SAVE_THREAD_STATE();    /* inline! */
380
381         /* The return code goes in BaseReg->rRet, and BaseReg is returned in R1 */
382         StgRegTable_rRet(BaseReg) = ThreadFinished;
383         R1 = BaseReg;
384
385         jump StgReturn;
386     }
387
388     /* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME.  Pop everything
389      * down to and including this frame, update Su, push R1, and enter the handler.
390      */
391     if (frame_type == CATCH_FRAME) {
392       handler = StgCatchFrame_handler(Sp);
393     } else {
394       handler = StgCatchSTMFrame_handler(Sp);
395     }
396
397     /* Restore the blocked/unblocked state for asynchronous exceptions
398      * at the CATCH_FRAME.  
399      *
400      * If exceptions were unblocked, arrange that they are unblocked
401      * again after executing the handler by pushing an
402      * unblockAsyncExceptions_ret stack frame.
403      */
404     W_ frame;
405     frame = Sp;
406     if (frame_type == CATCH_FRAME) {
407       Sp = Sp + SIZEOF_StgCatchFrame;
408       if (StgCatchFrame_exceptions_blocked(frame) == 0) {
409         Sp_adj(-1);
410         Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
411       }
412     } else {
413       Sp = Sp + SIZEOF_StgCatchSTMFrame;
414     }
415
416     /* Ensure that async excpetions are blocked when running the handler.
417     */
418     StgTSO_flags(CurrentTSO) = 
419         StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
420
421     /* Call the handler, passing the exception value and a realworld
422      * token as arguments.
423      */
424     Sp_adj(-1);
425     Sp(0) = R1;
426     R1 = handler;
427     Sp_adj(-1);
428     TICK_UNKNOWN_CALL();
429     TICK_SLOW_CALL_pv();
430     jump RET_LBL(stg_ap_pv);
431 }
432
433 raiseIOzh_fast
434 {
435   /* Args :: R1 :: Exception */
436   jump raisezh_fast;
437 }