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