Save and restore registers across calls to unlockClosure.
[ghc.git] / rts / HeapStackCheck.cmm
1 /* -----------------------------------------------------------------------------
2  *
3  * (c) The GHC Team, 1998-2004
4  *
5  * Canned Heap-Check and Stack-Check sequences.
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 "Updates.h"
15
16 #ifdef __PIC__
17 import pthread_mutex_unlock;
18 #endif
19 import EnterCriticalSection;
20 import LeaveCriticalSection;
21
22 /* Stack/Heap Check Failure
23  * ------------------------
24  *
25  * Both heap and stack check failures end up in the same place, so
26  * that we can share the code for the failure case when a proc needs
27  * both a stack check and a heap check (a common case).
28  *
29  * So when we get here, we have to tell the difference between a stack
30  * check failure and a heap check failure.  The code for the checks
31  * looks like this:
32
33         if (Sp - 16 < SpLim) goto c1Tf;
34         Hp = Hp + 16;
35         if (Hp > HpLim) goto c1Th;
36         ...
37     c1Th:
38         HpAlloc = 16;
39         goto c1Tf;
40     c1Tf: jump stg_gc_enter_1 ();
41
42  * Note that Sp is not decremented by the check, whereas Hp is.  The
43  * reasons for this seem to be largely historic, I can't think of a
44  * good reason not to decrement Sp at the check too. (--SDM)
45  *
46  * Note that HpLim may be set to zero arbitrarily by the timer signal
47  * or another processor to trigger a context switch via heap check
48  * failure.
49  *
50  * The job of these fragments (stg_gc_enter_1 and friends) is to
51  *   1. Leave no slop in the heap, so Hp must be retreated if it was
52  *      incremented by the check.  No-slop is a requirement for LDV
53  *      profiling, at least.
54  *   2. If a heap check failed, try to grab another heap block from
55  *      the nursery and continue.
56  *   3. otherwise, return to the scheduler with StackOverflow,
57  *      HeapOverflow, or ThreadYielding as appropriate.
58  *
59  * We can tell whether Hp was incremented, because HpAlloc is
60  * non-zero: HpAlloc is required to be zero at all times unless a
61  * heap-check just failed, which is why the stack-check failure case
62  * does not set HpAlloc (see code fragment above).  So that covers (1).
63  * HpAlloc is zeroed in LOAD_THREAD_STATE().
64  *
65  * If Hp > HpLim, then either (a) we have reached the end of the
66  * current heap block, or (b) HpLim == 0 and we should yield.  Hence
67  * check Hp > HpLim first, and then HpLim == 0 to decide whether to
68  * return ThreadYielding or try to grab another heap block from the
69  * nursery.
70  *
71  * If Hp <= HpLim, then this must be a StackOverflow.  The scheduler
72  * will either increase the size of our stack, or raise an exception if
73  * the stack is already too big.
74  */
75  
76 #define PRE_RETURN(why,what_next)                       \
77   StgTSO_what_next(CurrentTSO) = what_next::I16;        \
78   StgRegTable_rRet(BaseReg) = why;                      \
79   R1 = BaseReg;
80
81 /* Remember that the return address is *removed* when returning to a
82  * ThreadRunGHC thread.
83  */
84
85 stg_gc_noregs
86 {
87     W_ ret;
88
89     DEBUG_ONLY(foreign "C" heapCheckFail());
90     if (Hp > HpLim) {
91         Hp = Hp - HpAlloc/*in bytes*/;
92         if (HpLim == 0) {
93                 ret = ThreadYielding;
94                 goto sched;
95         }
96         if (HpAlloc <= BLOCK_SIZE
97             && bdescr_link(CurrentNursery) != NULL) {
98             HpAlloc = 0;
99             CLOSE_NURSERY();
100             CurrentNursery = bdescr_link(CurrentNursery);
101             OPEN_NURSERY();
102             if (Capability_context_switch(MyCapability()) != 0 :: CInt ||
103                 Capability_interrupt(MyCapability())      != 0 :: CInt) {
104                 ret = ThreadYielding;
105                 goto sched;
106             } else {
107                 jump %ENTRY_CODE(Sp(0)) [];
108             }
109         } else {
110             ret = HeapOverflow;
111             goto sched;
112         }
113     } else {
114         if (CHECK_GC()) {
115             ret = HeapOverflow;
116         } else {
117             ret = StackOverflow;
118         }
119     }
120   sched:
121     PRE_RETURN(ret,ThreadRunGHC);
122     jump stg_returnToSched [R1];
123 }
124
125 #define HP_GENERIC                              \
126     PRE_RETURN(HeapOverflow, ThreadRunGHC)      \
127     jump stg_returnToSched [R1];
128
129 #define BLOCK_GENERIC                           \
130     PRE_RETURN(ThreadBlocked,  ThreadRunGHC)    \
131     jump stg_returnToSched [R1];
132
133 #define YIELD_GENERIC                           \
134     PRE_RETURN(ThreadYielding, ThreadRunGHC)    \
135     jump stg_returnToSched [R1];
136
137 #define BLOCK_BUT_FIRST(c)                      \
138     PRE_RETURN(ThreadBlocked, ThreadRunGHC)     \
139     R2 = c;                                     \
140     jump stg_returnToSchedButFirst [R1,R2,R3];
141
142 #define YIELD_TO_INTERPRETER                    \
143     PRE_RETURN(ThreadYielding, ThreadInterpret) \
144     jump stg_returnToSchedNotPaused [R1];
145
146 /* -----------------------------------------------------------------------------
147    Heap checks in thunks/functions.
148
149    In these cases, node always points to the function closure.  This gives
150    us an easy way to return to the function: just leave R1 on the top of
151    the stack, and have the scheduler enter it to return.
152
153    There are canned sequences for 'n' pointer values in registers.
154    -------------------------------------------------------------------------- */
155
156 INFO_TABLE_RET ( stg_enter, RET_SMALL, W_ info_ptr, P_ closure )
157     return (/* no return values */)
158 {
159     ENTER(closure);
160 }
161
162 __stg_gc_enter_1 (P_ node)
163 {
164     jump stg_gc_noregs (stg_enter_info, node) ();
165 }
166
167 /* -----------------------------------------------------------------------------
168    Canned heap checks for primitives.
169
170    We can't use stg_gc_fun because primitives are not functions, so
171    these fragments let us save some boilerplate heap-check-failure
172    code in a few common cases.
173    -------------------------------------------------------------------------- */
174
175 stg_gc_prim ()
176 {
177     W_ fun;
178     fun = R9;
179     call stg_gc_noregs ();
180     jump fun();
181 }
182
183 stg_gc_prim_p (P_ arg)
184 {
185     W_ fun;
186     fun = R9;
187     call stg_gc_noregs ();
188     jump fun(arg);
189 }
190
191 stg_gc_prim_pp (P_ arg1, P_ arg2)
192 {
193     W_ fun;
194     fun = R9;
195     call stg_gc_noregs ();
196     jump fun(arg1,arg2);
197 }
198
199 stg_gc_prim_n (W_ arg)
200 {
201     W_ fun;
202     fun = R9;
203     call stg_gc_noregs ();
204     jump fun(arg);
205 }
206
207 /* -----------------------------------------------------------------------------
208    stg_enter_checkbh is just like stg_enter, except that we also call
209    checkBlockingQueues().  The point of this is that the GC can
210    replace an stg_marked_upd_frame with an stg_enter_checkbh if it
211    finds that the BLACKHOLE has already been updated by another
212    thread.  It would be unsafe to use stg_enter, because there might
213    be an orphaned BLOCKING_QUEUE now.
214    -------------------------------------------------------------------------- */
215
216 /* The stg_enter_checkbh frame has the same shape as an update frame: */
217
218 INFO_TABLE_RET ( stg_enter_checkbh, RET_SMALL,
219                  UPDATE_FRAME_FIELDS(W_,P_,info_ptr,ccs,p2,updatee))
220     return (P_ ret)
221 {
222     foreign "C" checkBlockingQueues(MyCapability() "ptr",
223                                     CurrentTSO);
224     return (updatee);
225 }
226
227 /* -----------------------------------------------------------------------------
228    Info tables for returning values of various types.  These are used
229    when we want to push a frame on the stack that will return a value
230    to the frame underneath it.
231    -------------------------------------------------------------------------- */
232
233 INFO_TABLE_RET ( stg_ret_v, RET_SMALL, W_ info_ptr )
234     return (/* no return values */)
235 {
236     return ();
237 }
238
239 INFO_TABLE_RET ( stg_ret_p, RET_SMALL, W_ info_ptr, P_ ptr )
240     return (/* no return values */)
241 {
242     return (ptr);
243 }
244
245 INFO_TABLE_RET ( stg_ret_n, RET_SMALL, W_ info_ptr, W_ nptr )
246     return (/* no return values */)
247 {
248     return (nptr);
249 }
250
251 INFO_TABLE_RET ( stg_ret_f, RET_SMALL, W_ info_ptr, F_ f )
252     return (/* no return values */)
253 {
254     return (f);
255 }
256
257 INFO_TABLE_RET ( stg_ret_d, RET_SMALL, W_ info_ptr, D_ d )
258     return (/* no return values */)
259 {
260     return (d);
261 }
262
263 INFO_TABLE_RET ( stg_ret_l, RET_SMALL, W_ info_ptr, L_ l )
264     return (/* no return values */)
265 {
266     return (l);
267 }
268
269 /* -----------------------------------------------------------------------------
270    Canned heap-check failures for case alts, where we have some values
271    in registers or on the stack according to the NativeReturn
272    convention.
273    -------------------------------------------------------------------------- */
274
275
276 /*-- void return ------------------------------------------------------------ */
277
278 /*-- R1 is a GC pointer, but we don't enter it ----------------------- */
279
280 stg_gc_unpt_r1 return (P_ ptr) /* NB. return convention */
281 {
282     jump stg_gc_noregs (stg_ret_p_info, ptr) ();
283 }
284
285 /*-- R1 is unboxed -------------------------------------------------- */
286
287 stg_gc_unbx_r1 return (W_ nptr) /* NB. return convention */
288 {
289     jump stg_gc_noregs (stg_ret_n_info, nptr) ();
290 }
291
292 /*-- F1 contains a float ------------------------------------------------- */
293
294 stg_gc_f1 return (F_ f)
295 {
296     jump stg_gc_noregs (stg_ret_f_info, f) ();
297 }
298
299 /*-- D1 contains a double ------------------------------------------------- */
300
301 stg_gc_d1 return (D_ d)
302 {
303     jump stg_gc_noregs (stg_ret_d_info, d) ();
304 }
305
306
307 /*-- L1 contains an int64 ------------------------------------------------- */
308
309 stg_gc_l1 return (L_ l)
310 {
311     jump stg_gc_noregs (stg_ret_l_info, l) ();
312 }
313
314 /*-- Unboxed tuples with multiple pointers -------------------------------- */
315
316 stg_gc_pp return (P_ arg1, P_ arg2)
317 {
318     call stg_gc_noregs();
319     return (arg1,arg2);
320 }
321
322 stg_gc_ppp return (P_ arg1, P_ arg2, P_ arg3)
323 {
324     call stg_gc_noregs();
325     return (arg1,arg2,arg3);
326 }
327
328 stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4)
329 {
330     call stg_gc_noregs();
331     return (arg1,arg2,arg3,arg4);
332 }
333
334 /* -----------------------------------------------------------------------------
335    Generic function entry heap check code.
336
337    At a function entry point, the arguments are as per the calling convention,
338    i.e. some in regs and some on the stack.  There may or may not be 
339    a pointer to the function closure in R1 - if there isn't, then the heap
340    check failure code in the function will arrange to load it.
341
342    The function's argument types are described in its info table, so we
343    can just jump to this bit of generic code to save away all the
344    registers and return to the scheduler.
345
346    This code arranges the stack like this:
347          
348          |        ....         |
349          |        args         |
350          +---------------------+
351          |      f_closure      |
352          +---------------------+
353          |        size         |
354          +---------------------+
355          |   stg_gc_fun_info   |
356          +---------------------+
357
358    The size is the number of words of arguments on the stack, and is cached
359    in the frame in order to simplify stack walking: otherwise the size of
360    this stack frame would have to be calculated by looking at f's info table.
361
362    -------------------------------------------------------------------------- */
363
364 __stg_gc_fun /* explicit stack */
365 {
366     W_ size;
367     W_ info;
368     W_ type;
369
370     info = %GET_FUN_INFO(UNTAG(R1));
371
372     // cache the size
373     type = TO_W_(StgFunInfoExtra_fun_type(info));
374     if (type == ARG_GEN) {
375         size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
376     } else { 
377         if (type == ARG_GEN_BIG) {
378 #ifdef TABLES_NEXT_TO_CODE
379             // bitmap field holds an offset
380             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
381                                         + %GET_ENTRY(UNTAG(R1)) /* ### */ );
382 #else
383             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
384 #endif
385         } else {
386             size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
387         }
388     }
389     
390 #ifdef NO_ARG_REGS
391     // we don't have to save any registers away
392     Sp_adj(-3);
393     Sp(2) = R1;
394     Sp(1) = size;
395     Sp(0) = stg_gc_fun_info;
396     jump stg_gc_noregs [];
397 #else
398     W_ type;
399     type = TO_W_(StgFunInfoExtra_fun_type(info));
400     // cache the size
401     if (type == ARG_GEN || type == ARG_GEN_BIG) {
402         // regs already saved by the heap check code
403         Sp_adj(-3);
404         Sp(2) = R1;
405         Sp(1) = size;
406         Sp(0) = stg_gc_fun_info;
407         // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
408         jump stg_gc_noregs [];
409     } else { 
410         jump W_[stg_stack_save_entries + WDS(type)] [*]; // all regs live
411             // jumps to stg_gc_noregs after saving stuff
412     }
413 #endif /* !NO_ARG_REGS */
414 }
415
416
417 /* -----------------------------------------------------------------------------
418    Generic Apply (return point)
419
420    The dual to stg_fun_gc_gen (above): this fragment returns to the
421    function, passing arguments in the stack and in registers
422    appropriately.  The stack layout is given above.
423    -------------------------------------------------------------------------- */
424
425 INFO_TABLE_RET ( stg_gc_fun, RET_FUN )
426     /* explicit stack */
427 {
428     R1 = Sp(2);
429     Sp_adj(3);
430 #ifdef NO_ARG_REGS
431     // Minor optimisation: there are no argument registers to load up,
432     // so we can just jump straight to the function's entry point.
433     jump %GET_ENTRY(UNTAG(R1)) [R1];
434 #else
435     W_ info;
436     W_ type;
437     
438     info = %GET_FUN_INFO(UNTAG(R1));
439     type = TO_W_(StgFunInfoExtra_fun_type(info));
440     if (type == ARG_GEN || type == ARG_GEN_BIG) {
441         jump StgFunInfoExtra_slow_apply(info) [R1];
442     } else { 
443         if (type == ARG_BCO) {
444             // cover this case just to be on the safe side
445             Sp_adj(-2);
446             Sp(1) = R1;
447             Sp(0) = stg_apply_interp_info;
448             jump stg_yield_to_interpreter [];
449         } else {
450             jump W_[stg_ap_stack_entries + WDS(type)] [R1];
451         }
452     }
453 #endif
454 }
455
456 /* -----------------------------------------------------------------------------
457    Yields
458    -------------------------------------------------------------------------- */
459
460 stg_yield_noregs
461 {
462     YIELD_GENERIC;
463 }
464
465 /* -----------------------------------------------------------------------------
466    Yielding to the interpreter... top of stack says what to do next.
467    -------------------------------------------------------------------------- */
468
469 stg_yield_to_interpreter
470 {
471     YIELD_TO_INTERPRETER;
472 }
473
474 /* -----------------------------------------------------------------------------
475    Blocks
476    -------------------------------------------------------------------------- */
477
478 stg_block_noregs
479 {
480     BLOCK_GENERIC;
481 }
482
483 /* -----------------------------------------------------------------------------
484  * takeMVar/putMVar-specific blocks
485  *
486  * Stack layout for a thread blocked in takeMVar:
487  *      
488  *       ret. addr
489  *       ptr to MVar   (R1)
490  *       stg_block_takemvar_info
491  *
492  * Stack layout for a thread blocked in putMVar:
493  *      
494  *       ret. addr
495  *       ptr to Value  (R2)
496  *       ptr to MVar   (R1)
497  *       stg_block_putmvar_info
498  *
499  * See PrimOps.hc for a description of the workings of take/putMVar.
500  * 
501  * -------------------------------------------------------------------------- */
502
503 INFO_TABLE_RET ( stg_block_takemvar, RET_SMALL, W_ info_ptr, P_ mvar )
504     return ()
505 {
506     jump stg_takeMVarzh(mvar);
507 }
508
509 // code fragment executed just before we return to the scheduler
510 stg_block_takemvar_finally
511 {
512     W_ r1, r3;
513     r1 = R1;
514     r3 = R3;
515     unlockClosure(R3, stg_MVAR_DIRTY_info);
516     R1 = r1;
517     R3 = r3;
518     jump StgReturn [R1];
519 }
520
521 stg_block_takemvar /* mvar passed in R1 */
522 {
523     Sp_adj(-2);
524     Sp(1) = R1;
525     Sp(0) = stg_block_takemvar_info;
526     R3 = R1; // mvar communicated to stg_block_takemvar_finally in R3
527     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
528 }
529
530 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr,
531                 P_ mvar, P_ val )
532     return ()
533 {
534     jump stg_putMVarzh(mvar, val);
535 }
536
537 // code fragment executed just before we return to the scheduler
538 stg_block_putmvar_finally
539 {
540     W_ r1, r3;
541     r1 = R1;
542     r3 = R3;
543     unlockClosure(R3, stg_MVAR_DIRTY_info);
544     R1 = r1;
545     R3 = r3;
546     jump StgReturn [R1];
547 }
548
549 stg_block_putmvar (P_ mvar, P_ val)
550 {
551     push (stg_block_putmvar_info, mvar, val) {
552       R3 = R1; // mvar communicated to stg_block_putmvar_finally in R3
553       BLOCK_BUT_FIRST(stg_block_putmvar_finally);
554    }
555 }
556
557 stg_block_blackhole
558 {
559     Sp_adj(-2);
560     Sp(1) = R1;
561     Sp(0) = stg_enter_info;
562     BLOCK_GENERIC;
563 }
564
565 INFO_TABLE_RET ( stg_block_throwto, RET_SMALL, W_ info_ptr,
566                  P_ tso, P_ exception )
567     return ()
568 {
569     jump stg_killThreadzh(tso, exception);
570 }
571
572 stg_block_throwto_finally
573 {
574     // unlock the throwto message, but only if it wasn't already
575     // unlocked.  It may have been unlocked if we revoked the message
576     // due to an exception being raised during threadPaused().
577     if (StgHeader_info(StgTSO_block_info(CurrentTSO)) == stg_WHITEHOLE_info) {
578         W_ r1;
579         r1 = R1;
580         unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info);
581         R1 = r1;
582     }
583     jump StgReturn [R1];
584 }
585
586 stg_block_throwto (P_ tso, P_ exception)
587 {
588     push (stg_block_throwto_info, tso, exception) {
589        BLOCK_BUT_FIRST(stg_block_throwto_finally);
590     }
591 }
592
593 #ifdef mingw32_HOST_OS
594 INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares )
595     return ()
596 {
597     W_ len, errC;
598
599     len = TO_W_(StgAsyncIOResult_len(ares));
600     errC = TO_W_(StgAsyncIOResult_errCode(ares));
601     ccall free(ares "ptr");
602     return (len, errC);
603 }
604
605 stg_block_async
606 {
607     Sp_adj(-2);
608     Sp(0) = stg_block_async_info;
609     BLOCK_GENERIC;
610 }
611
612 /* Used by threadDelay implementation; it would be desirable to get rid of
613  * this free()'ing void return continuation.
614  */
615 INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares )
616     return ()
617 {
618     ccall free(ares "ptr");
619     return ();
620 }
621
622 stg_block_async_void
623 {
624     Sp_adj(-2);
625     Sp(0) = stg_block_async_void_info;
626     BLOCK_GENERIC;
627 }
628
629 #endif
630
631
632 /* -----------------------------------------------------------------------------
633    STM-specific waiting
634    -------------------------------------------------------------------------- */
635
636 stg_block_stmwait_finally
637 {
638     ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
639     jump StgReturn [R1];
640 }
641
642 stg_block_stmwait
643 {
644     BLOCK_BUT_FIRST(stg_block_stmwait_finally);
645 }