Produce new-style Cmm from the Cmm parser
[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,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     unlockClosure(R3, stg_MVAR_DIRTY_info);
513     jump StgReturn [R1];
514 }
515
516 stg_block_takemvar /* mvar passed in R1 */
517 {
518     Sp_adj(-2);
519     Sp(1) = R1;
520     Sp(0) = stg_block_takemvar_info;
521     R3 = R1; // mvar communicated to stg_block_takemvar_finally in R3
522     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
523 }
524
525 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr,
526                 P_ mvar, P_ val )
527     return ()
528 {
529     jump stg_putMVarzh(mvar, val);
530 }
531
532 // code fragment executed just before we return to the scheduler
533 stg_block_putmvar_finally
534 {
535     unlockClosure(R3, stg_MVAR_DIRTY_info);
536     jump StgReturn [R1];
537 }
538
539 stg_block_putmvar (P_ mvar, P_ val)
540 {
541     push (stg_block_putmvar_info, mvar, val) {
542       R3 = R1; // mvar communicated to stg_block_putmvar_finally in R3
543       BLOCK_BUT_FIRST(stg_block_putmvar_finally);
544    }
545 }
546
547 stg_block_blackhole
548 {
549     Sp_adj(-2);
550     Sp(1) = R1;
551     Sp(0) = stg_enter_info;
552     BLOCK_GENERIC;
553 }
554
555 INFO_TABLE_RET ( stg_block_throwto, RET_SMALL, W_ info_ptr,
556                  P_ tso, P_ exception )
557     return ()
558 {
559     jump stg_killThreadzh(tso, exception);
560 }
561
562 stg_block_throwto_finally
563 {
564     // unlock the throwto message, but only if it wasn't already
565     // unlocked.  It may have been unlocked if we revoked the message
566     // due to an exception being raised during threadPaused().
567     if (StgHeader_info(StgTSO_block_info(CurrentTSO)) == stg_WHITEHOLE_info) {
568         unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info);
569     }
570     jump StgReturn [R1];
571 }
572
573 stg_block_throwto (P_ tso, P_ exception)
574 {
575     push (stg_block_throwto_info, tso, exception) {
576        BLOCK_BUT_FIRST(stg_block_throwto_finally);
577     }
578 }
579
580 #ifdef mingw32_HOST_OS
581 INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares )
582     return ()
583 {
584     W_ len, errC;
585
586     len = TO_W_(StgAsyncIOResult_len(ares));
587     errC = TO_W_(StgAsyncIOResult_errCode(ares));
588     ccall free(ares "ptr");
589     return (len, errC);
590 }
591
592 stg_block_async
593 {
594     Sp_adj(-2);
595     Sp(0) = stg_block_async_info;
596     BLOCK_GENERIC;
597 }
598
599 /* Used by threadDelay implementation; it would be desirable to get rid of
600  * this free()'ing void return continuation.
601  */
602 INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares )
603     return ()
604 {
605     ccall free(ares "ptr");
606     return ();
607 }
608
609 stg_block_async_void
610 {
611     Sp_adj(-2);
612     Sp(0) = stg_block_async_void_info;
613     BLOCK_GENERIC;
614 }
615
616 #endif
617
618
619 /* -----------------------------------------------------------------------------
620    STM-specific waiting
621    -------------------------------------------------------------------------- */
622
623 stg_block_stmwait_finally
624 {
625     ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
626     jump StgReturn [R1];
627 }
628
629 stg_block_stmwait
630 {
631     BLOCK_BUT_FIRST(stg_block_stmwait_finally);
632 }