add new primop: asyncExceptionsBlocked# :: IO Bool
[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 import ghczmprim_GHCziBool_True_closure;
17
18 /* -----------------------------------------------------------------------------
19    Exception Primitives
20
21    A thread can request that asynchronous exceptions not be delivered
22    ("blocked") for the duration of an I/O computation.  The primitive
23    
24         blockAsyncExceptions# :: IO a -> IO a
25
26    is used for this purpose.  During a blocked section, asynchronous
27    exceptions may be unblocked again temporarily:
28
29         unblockAsyncExceptions# :: IO a -> IO a
30
31    Furthermore, asynchronous exceptions are blocked automatically during
32    the execution of an exception handler.  Both of these primitives
33    leave a continuation on the stack which reverts to the previous
34    state (blocked or unblocked) on exit.
35
36    A thread which wants to raise an exception in another thread (using
37    killThread#) must block until the target thread is ready to receive
38    it.  The action of unblocking exceptions in a thread will release all
39    the threads waiting to deliver exceptions to that thread.
40
41    NB. there's a bug in here.  If a thread is inside an
42    unsafePerformIO, and inside blockAsyncExceptions# (there is an
43    unblockAsyncExceptions_ret on the stack), and it is blocked in an
44    interruptible operation, and it receives an exception, then the
45    unsafePerformIO thunk will be updated with a stack object
46    containing the unblockAsyncExceptions_ret frame.  Later, when
47    someone else evaluates this thunk, the blocked exception state is
48    not restored.
49
50    -------------------------------------------------------------------------- */
51
52 INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, RET_SMALL )
53 {
54     CInt r;
55
56     StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
57         ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
58
59     /* Eagerly raise a blocked exception, if there is one */
60     if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
61         /* 
62          * We have to be very careful here, as in killThread#, since
63          * we are about to raise an async exception in the current
64          * thread, which might result in the thread being killed.
65          */
66
67 #ifndef REG_R1
68         /*
69          * raiseAsync assumes that the stack is in ThreadRunGHC state,
70          * i.e. with a return address on the top.  In unreg mode, the
71          * return value for IO is on top of the return address, so we
72          * need to make a small adjustment here.
73          */
74         Sp_adj(1);
75 #endif
76         STK_CHK_GEN( WDS(2), R1_PTR, stg_unblockAsyncExceptionszh_ret_info);
77         Sp_adj(-2);
78         Sp(1) = R1;
79 #ifdef REG_R1
80         Sp(0) = stg_gc_unpt_r1_info;
81 #else
82         Sp(0) = stg_ut_1_0_unreg_info;
83 #endif
84         SAVE_THREAD_STATE();
85         (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
86                                                       CurrentTSO "ptr") [R1];
87
88         if (r != 0::CInt) {
89             if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
90                 jump stg_threadFinished;
91             } else {
92                 LOAD_THREAD_STATE();
93                 ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
94                 jump %ENTRY_CODE(Sp(0));
95             }
96         }
97 #ifndef REG_R1
98         /* 
99          * Readjust stack in unregisterised mode if we didn't raise an
100          * exception, see above
101          */
102         else {
103             Sp_adj(-1);
104         }
105 #endif
106     }
107
108 #ifdef REG_R1
109     Sp_adj(1);
110     jump %ENTRY_CODE(Sp(0));
111 #else
112     Sp(1) = Sp(0);
113     Sp_adj(1);
114     jump %ENTRY_CODE(Sp(1));
115 #endif
116 }
117
118 INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, RET_SMALL )
119 {
120     StgTSO_flags(CurrentTSO) = 
121         StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
122
123 #ifdef REG_R1
124     Sp_adj(1);
125     jump %ENTRY_CODE(Sp(0));
126 #else
127     Sp(1) = Sp(0);
128     Sp_adj(1);
129     jump %ENTRY_CODE(Sp(1));
130 #endif
131 }
132
133 blockAsyncExceptionszh_fast
134 {
135     /* Args: R1 :: IO a */
136     STK_CHK_GEN( WDS(2)/* worst case */, R1_PTR, blockAsyncExceptionszh_fast);
137
138     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
139         
140         StgTSO_flags(CurrentTSO) = 
141            StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
142
143         /* avoid growing the stack unnecessarily */
144         if (Sp(0) == stg_blockAsyncExceptionszh_ret_info) {
145             Sp_adj(1);
146         } else {
147             Sp_adj(-1);
148             Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
149         }
150     }
151     TICK_UNKNOWN_CALL();
152     TICK_SLOW_CALL_v();
153     jump stg_ap_v_fast;
154 }
155
156 unblockAsyncExceptionszh_fast
157 {
158     CInt r;
159
160     /* Args: R1 :: IO a */
161     STK_CHK_GEN( WDS(2), R1_PTR, unblockAsyncExceptionszh_fast);
162
163     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
164
165         StgTSO_flags(CurrentTSO) = StgTSO_flags(CurrentTSO) & 
166            ~(TSO_BLOCKEX::I32|TSO_INTERRUPTIBLE::I32);
167
168         /* Eagerly raise a blocked exception, if there is one */
169         if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
170             /* 
171              * We have to be very careful here, as in killThread#, since
172              * we are about to raise an async exception in the current
173              * thread, which might result in the thread being killed.
174              */
175             SAVE_THREAD_STATE();
176             (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
177                                                       CurrentTSO "ptr") [R1];
178
179             if (r != 0::CInt) {
180                 if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
181                     jump stg_threadFinished;
182                 } else {
183                     LOAD_THREAD_STATE();
184                     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
185                     jump %ENTRY_CODE(Sp(0));
186                 }
187             }
188         }
189
190         /* avoid growing the stack unnecessarily */
191         if (Sp(0) == stg_unblockAsyncExceptionszh_ret_info) {
192             Sp_adj(1);
193         } else {
194             Sp_adj(-1);
195             Sp(0) = stg_blockAsyncExceptionszh_ret_info;
196         }
197     }
198     TICK_UNKNOWN_CALL();
199     TICK_SLOW_CALL_v();
200     jump stg_ap_v_fast;
201 }
202
203 asyncExceptionsBlockedzh_fast
204 {
205     /* args: none */
206     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) {
207         RET_N(1);
208     } else {
209         RET_N(0);
210     }
211 }
212
213 killThreadzh_fast
214 {
215     /* args: R1 = TSO to kill, R2 = Exception */
216
217     W_ why_blocked;
218     W_ target;
219     W_ exception;
220     
221     target = R1;
222     exception = R2;
223     
224     STK_CHK_GEN( WDS(3), R1_PTR & R2_PTR, killThreadzh_fast);
225
226     /* 
227      * We might have killed ourselves.  In which case, better be *very*
228      * careful.  If the exception killed us, then return to the scheduler.
229      * If the exception went to a catch frame, we'll just continue from
230      * the handler.
231      */
232   loop:
233     if (StgTSO_what_next(target) == ThreadRelocated::I16) {
234         target = StgTSO__link(target);
235         goto loop;
236     }
237     if (target == CurrentTSO) {
238         SAVE_THREAD_STATE();
239         /* ToDo: what if the current thread is blocking exceptions? */
240         foreign "C" throwToSingleThreaded(MyCapability() "ptr", 
241                                           target "ptr", exception "ptr")[R1,R2];
242         if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
243             jump stg_threadFinished;
244         } else {
245             LOAD_THREAD_STATE();
246             ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
247             jump %ENTRY_CODE(Sp(0));
248         }
249     } else {
250         W_ out;
251         W_ retcode;
252         out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w;
253         
254         (retcode) = foreign "C" throwTo(MyCapability() "ptr",
255                                       CurrentTSO "ptr",
256                                       target "ptr",
257                                       exception "ptr",
258                                       out "ptr") [R1,R2];
259         
260         switch [THROWTO_SUCCESS .. THROWTO_BLOCKED] (retcode) {
261
262         case THROWTO_SUCCESS: {
263             jump %ENTRY_CODE(Sp(0));
264         }
265
266         case THROWTO_BLOCKED: {
267             R3 = W_[out];
268             // we must block, and call throwToReleaseTarget() before returning
269             jump stg_block_throwto;
270         }
271         }
272     }
273 }
274
275 /* -----------------------------------------------------------------------------
276    Catch frames
277    -------------------------------------------------------------------------- */
278
279 #ifdef REG_R1
280 #define SP_OFF 0
281 #else
282 #define SP_OFF 1
283 #endif
284
285 /* Catch frames are very similar to update frames, but when entering
286  * one we just pop the frame off the stack and perform the correct
287  * kind of return to the activation record underneath us on the stack.
288  */
289
290 INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
291 #if defined(PROFILING)
292   W_ unused1, W_ unused2,
293 #endif
294   W_ unused3, "ptr" W_ unused4)
295 #ifdef REG_R1
296    {
297       Sp = Sp + SIZEOF_StgCatchFrame;
298       jump %ENTRY_CODE(Sp(SP_OFF));
299    }
300 #else
301    {
302       W_ rval;
303       rval = Sp(0);
304       Sp = Sp + SIZEOF_StgCatchFrame;
305       Sp(0) = rval;
306       jump %ENTRY_CODE(Sp(SP_OFF));
307    }
308 #endif
309
310 /* -----------------------------------------------------------------------------
311  * The catch infotable
312  *
313  * This should be exactly the same as would be generated by this STG code
314  *
315  * catch = {x,h} \n {} -> catch#{x,h}
316  *
317  * It is used in deleteThread when reverting blackholes.
318  * -------------------------------------------------------------------------- */
319
320 INFO_TABLE(stg_catch,2,0,FUN,"catch","catch")
321 {
322   R2 = StgClosure_payload(R1,1); /* h */
323   R1 = StgClosure_payload(R1,0); /* x */
324   jump catchzh_fast;
325 }
326
327 catchzh_fast
328 {
329     /* args: R1 = m :: IO a, R2 = handler :: Exception -> IO a */
330     STK_CHK_GEN(SIZEOF_StgCatchFrame + WDS(1), R1_PTR & R2_PTR, catchzh_fast);
331   
332     /* Set up the catch frame */
333     Sp = Sp - SIZEOF_StgCatchFrame;
334     SET_HDR(Sp,stg_catch_frame_info,W_[CCCS]);
335     
336     StgCatchFrame_handler(Sp) = R2;
337     StgCatchFrame_exceptions_blocked(Sp) = TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX;
338     TICK_CATCHF_PUSHED();
339
340     /* Apply R1 to the realworld token */
341     TICK_UNKNOWN_CALL();
342     TICK_SLOW_CALL_v();
343     jump stg_ap_v_fast;
344 }
345
346 /* -----------------------------------------------------------------------------
347  * The raise infotable
348  * 
349  * This should be exactly the same as would be generated by this STG code
350  *
351  *   raise = {err} \n {} -> raise#{err}
352  *
353  * It is used in raisezh_fast to update thunks on the update list
354  * -------------------------------------------------------------------------- */
355
356 INFO_TABLE(stg_raise,1,0,THUNK_1_0,"raise","raise")
357 {
358   R1 = StgThunk_payload(R1,0);
359   jump raisezh_fast;
360 }
361
362 section "data" {
363   no_break_on_exception: W_[1];
364 }
365
366 INFO_TABLE_RET(stg_raise_ret, RET_SMALL, "ptr" W_ arg1)
367 {
368   R1 = Sp(1);
369   Sp = Sp + WDS(2);
370   W_[no_break_on_exception] = 1;  
371   jump raisezh_fast;
372 }
373
374 raisezh_fast
375 {
376     W_ handler;
377     W_ frame_type;
378     W_ exception;
379     /* args : R1 :: Exception */
380
381    exception = R1;
382
383 #if defined(PROFILING)
384     /* Debugging tool: on raising an  exception, show where we are. */
385
386     /* ToDo: currently this is a hack.  Would be much better if
387      * the info was only displayed for an *uncaught* exception.
388      */
389     if (RtsFlags_ProfFlags_showCCSOnException(RtsFlags) != 0::I32) {
390       foreign "C" fprintCCS_stderr(W_[CCCS] "ptr") [];
391     }
392 #endif
393     
394 retry_pop_stack:
395     StgTSO_sp(CurrentTSO) = Sp;
396     (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
397     Sp = StgTSO_sp(CurrentTSO);
398     if (frame_type == ATOMICALLY_FRAME) {
399       /* The exception has reached the edge of a memory transaction.  Check that 
400        * the transaction is valid.  If not then perhaps the exception should
401        * not have been thrown: re-run the transaction.  "trec" will either be
402        * a top-level transaction running the atomic block, or a nested 
403        * transaction running an invariant check.  In the latter case we
404        * abort and de-allocate the top-level transaction that encloses it
405        * as well (we could just abandon its transaction record, but this makes
406        * sure it's marked as aborted and available for re-use). */
407       W_ trec, outer;
408       W_ r;
409       trec = StgTSO_trec(CurrentTSO);
410       (r) = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
411       ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
412       foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
413       foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
414
415       if (outer != NO_TREC) {
416         foreign "C" stmAbortTransaction(MyCapability() "ptr", outer "ptr") [];
417         foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", outer "ptr") [];
418       }
419
420       StgTSO_trec(CurrentTSO) = NO_TREC;
421       if (r != 0) {
422         // Transaction was valid: continue searching for a catch frame
423         Sp = Sp + SIZEOF_StgAtomicallyFrame;
424         goto retry_pop_stack;
425       } else {
426         // Transaction was not valid: we retry the exception (otherwise continue
427         // with a further call to raiseExceptionHelper)
428         ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
429         StgTSO_trec(CurrentTSO) = trec;
430         R1 = StgAtomicallyFrame_code(Sp);
431         jump stg_ap_v_fast;
432       }          
433     }
434
435     // After stripping the stack, see whether we should break here for
436     // GHCi (c.f. the -fbreak-on-exception flag).  We do this after
437     // stripping the stack for a reason: we'll be inspecting values in
438     // GHCi, and it helps if all the thunks under evaluation have
439     // already been updated with the exception, rather than being left
440     // as blackholes.
441     if (W_[no_break_on_exception] != 0) {
442         W_[no_break_on_exception] = 0;
443     } else {
444         if (TO_W_(CInt[rts_stop_on_exception]) != 0) {
445             W_ ioAction;
446             // we don't want any further exceptions to be caught,
447             // until GHCi is ready to handle them.  This prevents
448             // deadlock if an exception is raised in InteractiveUI,
449             // for exmplae.  Perhaps the stop_on_exception flag should
450             // be per-thread.
451             W_[rts_stop_on_exception] = 0;
452             ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
453             Sp = Sp - WDS(7);
454             Sp(6) = exception;
455             Sp(5) = stg_raise_ret_info;
456             Sp(4) = stg_noforceIO_info;    // required for unregisterised
457             Sp(3) = exception;             // the AP_STACK
458             Sp(2) = ghczmprim_GHCziBool_True_closure; // dummy breakpoint info
459             Sp(1) = ghczmprim_GHCziBool_True_closure; // True <=> a breakpoint
460             R1 = ioAction;
461             jump RET_LBL(stg_ap_pppv);
462         }
463     }
464
465     if (frame_type == STOP_FRAME) {
466         /*
467          * We've stripped the entire stack, the thread is now dead.
468          * We will leave the stack in a GC'able state, see the stg_stop_thread
469          * entry code in StgStartup.cmm.
470          */
471         Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack 
472                 + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2);
473         Sp(1) = exception;      /* save the exception */
474         Sp(0) = stg_enter_info; /* so that GC can traverse this stack */
475         StgTSO_what_next(CurrentTSO) = ThreadKilled::I16;
476         SAVE_THREAD_STATE();    /* inline! */
477
478         jump stg_threadFinished;
479     }
480
481     /* Ok, Sp points to the enclosing CATCH_FRAME or CATCH_STM_FRAME.  Pop everything
482      * down to and including this frame, update Su, push R1, and enter the handler.
483      */
484     if (frame_type == CATCH_FRAME) {
485       handler = StgCatchFrame_handler(Sp);
486     } else {
487       handler = StgCatchSTMFrame_handler(Sp);
488     }
489
490     /* Restore the blocked/unblocked state for asynchronous exceptions
491      * at the CATCH_FRAME.  
492      *
493      * If exceptions were unblocked, arrange that they are unblocked
494      * again after executing the handler by pushing an
495      * unblockAsyncExceptions_ret stack frame.
496      *
497      * If we've reached an STM catch frame then roll back the nested
498      * transaction we were using.
499      */
500     W_ frame;
501     frame = Sp;
502     if (frame_type == CATCH_FRAME) {
503       Sp = Sp + SIZEOF_StgCatchFrame;
504       if (StgCatchFrame_exceptions_blocked(frame) == 0) {
505         Sp_adj(-1);
506         Sp(0) = stg_unblockAsyncExceptionszh_ret_info;
507       }
508     } else {
509       W_ trec, outer;
510       trec = StgTSO_trec(CurrentTSO);
511       ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
512       foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
513       foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
514       StgTSO_trec(CurrentTSO) = outer;
515       Sp = Sp + SIZEOF_StgCatchSTMFrame;
516     }
517
518     /* Ensure that async excpetions are blocked when running the handler.
519     */
520     StgTSO_flags(CurrentTSO) = 
521         StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
522
523     /* Call the handler, passing the exception value and a realworld
524      * token as arguments.
525      */
526     Sp_adj(-1);
527     Sp(0) = exception;
528     R1 = handler;
529     Sp_adj(-1);
530     TICK_UNKNOWN_CALL();
531     TICK_SLOW_CALL_pv();
532     jump RET_LBL(stg_ap_pv);
533 }
534
535 raiseIOzh_fast
536 {
537   /* Args :: R1 :: Exception */
538   jump raisezh_fast;
539 }