Fix testsuite driver for a profiling compiler
[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             Capability_total_allocated(MyCapability()) =
101               Capability_total_allocated(MyCapability()) +
102               BYTES_TO_WDS(bdescr_free(CurrentNursery) -
103                            bdescr_start(CurrentNursery));
104             CurrentNursery = bdescr_link(CurrentNursery);
105             bdescr_free(CurrentNursery) = bdescr_start(CurrentNursery);
106             OPEN_NURSERY();
107             if (Capability_context_switch(MyCapability()) != 0 :: CInt ||
108                 Capability_interrupt(MyCapability())      != 0 :: CInt ||
109                 (StgTSO_alloc_limit(CurrentTSO) `lt` (0::I64) &&
110                  (TO_W_(StgTSO_flags(CurrentTSO)) & TSO_ALLOC_LIMIT) != 0)) {
111                 ret = ThreadYielding;
112                 goto sched;
113             } else {
114                 jump %ENTRY_CODE(Sp(0)) [];
115             }
116         } else {
117             ret = HeapOverflow;
118             goto sched;
119         }
120     } else {
121         if (CHECK_GC()) {
122             ret = HeapOverflow;
123         } else {
124             ret = StackOverflow;
125         }
126     }
127   sched:
128     PRE_RETURN(ret,ThreadRunGHC);
129     jump stg_returnToSched [R1];
130 }
131
132 #define HP_GENERIC                              \
133     PRE_RETURN(HeapOverflow, ThreadRunGHC)      \
134     jump stg_returnToSched [R1];
135
136 #define BLOCK_GENERIC                           \
137     PRE_RETURN(ThreadBlocked,  ThreadRunGHC)    \
138     jump stg_returnToSched [R1];
139
140 #define YIELD_GENERIC                           \
141     PRE_RETURN(ThreadYielding, ThreadRunGHC)    \
142     jump stg_returnToSched [R1];
143
144 #define BLOCK_BUT_FIRST(c)                      \
145     PRE_RETURN(ThreadBlocked, ThreadRunGHC)     \
146     R2 = c;                                     \
147     jump stg_returnToSchedButFirst [R1,R2,R3];
148
149 #define YIELD_TO_INTERPRETER                    \
150     PRE_RETURN(ThreadYielding, ThreadInterpret) \
151     jump stg_returnToSchedNotPaused [R1];
152
153 /* -----------------------------------------------------------------------------
154    Heap checks in thunks/functions.
155
156    In these cases, node always points to the function closure.  This gives
157    us an easy way to return to the function: just leave R1 on the top of
158    the stack, and have the scheduler enter it to return.
159
160    There are canned sequences for 'n' pointer values in registers.
161    -------------------------------------------------------------------------- */
162
163 INFO_TABLE_RET ( stg_enter, RET_SMALL, W_ info_ptr, P_ closure )
164     return (/* no return values */)
165 {
166     ENTER(closure);
167 }
168
169 __stg_gc_enter_1 (P_ node)
170 {
171     jump stg_gc_noregs (stg_enter_info, node) ();
172 }
173
174 /* -----------------------------------------------------------------------------
175    Canned heap checks for primitives.
176
177    We can't use stg_gc_fun because primitives are not functions, so
178    these fragments let us save some boilerplate heap-check-failure
179    code in a few common cases.
180    -------------------------------------------------------------------------- */
181
182 stg_gc_prim (W_ fun)
183 {
184     call stg_gc_noregs ();
185     jump fun();
186 }
187
188 stg_gc_prim_p (P_ arg, W_ fun)
189 {
190     call stg_gc_noregs ();
191     jump fun(arg);
192 }
193
194 stg_gc_prim_pp (P_ arg1, P_ arg2, W_ fun)
195 {
196     call stg_gc_noregs ();
197     jump fun(arg1,arg2);
198 }
199
200 stg_gc_prim_n (W_ arg, W_ fun)
201 {
202     call stg_gc_noregs ();
203     jump fun(arg);
204 }
205
206 INFO_TABLE_RET(stg_gc_prim_p_ll, RET_SMALL, W_ info, P_ arg, W_ fun)
207     /* explicit stack */
208 {
209     W_ fun;
210     P_ arg;
211     fun = Sp(2);
212     arg = Sp(1);
213     Sp_adj(3);
214     R1 = arg;
215     jump fun [R1];
216 }
217
218 stg_gc_prim_p_ll
219 {
220     W_ fun;
221     P_ arg;
222     fun = R2;
223     arg = R1;
224     Sp_adj(-3);
225     Sp(2) = fun;
226     Sp(1) = arg;
227     Sp(0) = stg_gc_prim_p_ll_info;
228     jump stg_gc_noregs [];
229 }
230
231 /* -----------------------------------------------------------------------------
232    stg_enter_checkbh is just like stg_enter, except that we also call
233    checkBlockingQueues().  The point of this is that the GC can
234    replace an stg_marked_upd_frame with an stg_enter_checkbh if it
235    finds that the BLACKHOLE has already been updated by another
236    thread.  It would be unsafe to use stg_enter, because there might
237    be an orphaned BLOCKING_QUEUE now.
238    -------------------------------------------------------------------------- */
239
240 /* The stg_enter_checkbh frame has the same shape as an update frame: */
241
242 INFO_TABLE_RET ( stg_enter_checkbh, RET_SMALL,
243                  UPDATE_FRAME_FIELDS(W_,P_,info_ptr,ccs,p2,updatee))
244     return (P_ ret)
245 {
246     foreign "C" checkBlockingQueues(MyCapability() "ptr",
247                                     CurrentTSO);
248
249     // we need to return updatee now.  Note that it might be a pointer
250     // to an indirection or a tagged value, we don't know which, so we
251     // need to ENTER() rather than return().
252     ENTER(updatee);
253 }
254
255 /* -----------------------------------------------------------------------------
256    Info tables for returning values of various types.  These are used
257    when we want to push a frame on the stack that will return a value
258    to the frame underneath it.
259    -------------------------------------------------------------------------- */
260
261 INFO_TABLE_RET ( stg_ret_v, RET_SMALL, W_ info_ptr )
262     return (/* no return values */)
263 {
264     return ();
265 }
266
267 INFO_TABLE_RET ( stg_ret_p, RET_SMALL, W_ info_ptr, P_ ptr )
268     return (/* no return values */)
269 {
270     return (ptr);
271 }
272
273 INFO_TABLE_RET ( stg_ret_n, RET_SMALL, W_ info_ptr, W_ nptr )
274     return (/* no return values */)
275 {
276     return (nptr);
277 }
278
279 INFO_TABLE_RET ( stg_ret_f, RET_SMALL, W_ info_ptr, F_ f )
280     return (/* no return values */)
281 {
282     return (f);
283 }
284
285 INFO_TABLE_RET ( stg_ret_d, RET_SMALL, W_ info_ptr, D_ d )
286     return (/* no return values */)
287 {
288     return (d);
289 }
290
291 INFO_TABLE_RET ( stg_ret_l, RET_SMALL, W_ info_ptr, L_ l )
292     return (/* no return values */)
293 {
294     return (l);
295 }
296
297 /* -----------------------------------------------------------------------------
298    Canned heap-check failures for case alts, where we have some values
299    in registers or on the stack according to the NativeReturn
300    convention.
301    -------------------------------------------------------------------------- */
302
303
304 /*-- void return ------------------------------------------------------------ */
305
306 /*-- R1 is a GC pointer, but we don't enter it ----------------------- */
307
308 stg_gc_unpt_r1 return (P_ ptr) /* NB. return convention */
309 {
310     jump stg_gc_noregs (stg_ret_p_info, ptr) ();
311 }
312
313 /*-- R1 is unboxed -------------------------------------------------- */
314
315 stg_gc_unbx_r1 return (W_ nptr) /* NB. return convention */
316 {
317     jump stg_gc_noregs (stg_ret_n_info, nptr) ();
318 }
319
320 /*-- F1 contains a float ------------------------------------------------- */
321
322 stg_gc_f1 return (F_ f)
323 {
324     jump stg_gc_noregs (stg_ret_f_info, f) ();
325 }
326
327 /*-- D1 contains a double ------------------------------------------------- */
328
329 stg_gc_d1 return (D_ d)
330 {
331     jump stg_gc_noregs (stg_ret_d_info, d) ();
332 }
333
334
335 /*-- L1 contains an int64 ------------------------------------------------- */
336
337 stg_gc_l1 return (L_ l)
338 {
339     jump stg_gc_noregs (stg_ret_l_info, l) ();
340 }
341
342 /*-- Unboxed tuples with multiple pointers -------------------------------- */
343
344 stg_gc_pp return (P_ arg1, P_ arg2)
345 {
346     call stg_gc_noregs();
347     return (arg1,arg2);
348 }
349
350 stg_gc_ppp return (P_ arg1, P_ arg2, P_ arg3)
351 {
352     call stg_gc_noregs();
353     return (arg1,arg2,arg3);
354 }
355
356 stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4)
357 {
358     call stg_gc_noregs();
359     return (arg1,arg2,arg3,arg4);
360 }
361
362 /* -----------------------------------------------------------------------------
363    Generic function entry heap check code.
364
365    At a function entry point, the arguments are as per the calling convention,
366    i.e. some in regs and some on the stack.  There may or may not be
367    a pointer to the function closure in R1 - if there isn't, then the heap
368    check failure code in the function will arrange to load it.
369
370    The function's argument types are described in its info table, so we
371    can just jump to this bit of generic code to save away all the
372    registers and return to the scheduler.
373
374    This code arranges the stack like this:
375
376          |        ....         |
377          |        args         |
378          +---------------------+
379          |      f_closure      |
380          +---------------------+
381          |        size         |
382          +---------------------+
383          |   stg_gc_fun_info   |
384          +---------------------+
385
386    The size is the number of words of arguments on the stack, and is cached
387    in the frame in order to simplify stack walking: otherwise the size of
388    this stack frame would have to be calculated by looking at f's info table.
389
390    -------------------------------------------------------------------------- */
391
392 __stg_gc_fun /* explicit stack */
393 {
394     W_ size;
395     W_ info;
396     W_ type;
397
398     info = %GET_FUN_INFO(UNTAG(R1));
399
400     // cache the size
401     type = TO_W_(StgFunInfoExtra_fun_type(info));
402     if (type == ARG_GEN) {
403         size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
404     } else {
405         if (type == ARG_GEN_BIG) {
406 #ifdef TABLES_NEXT_TO_CODE
407             // bitmap field holds an offset
408             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
409                                         + %GET_ENTRY(UNTAG(R1)) /* ### */ );
410 #else
411             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
412 #endif
413         } else {
414             size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
415         }
416     }
417
418 #ifdef NO_ARG_REGS
419     // we don't have to save any registers away
420     Sp_adj(-3);
421     Sp(2) = R1;
422     Sp(1) = size;
423     Sp(0) = stg_gc_fun_info;
424     jump stg_gc_noregs [];
425 #else
426     W_ type;
427     type = TO_W_(StgFunInfoExtra_fun_type(info));
428     // cache the size
429     if (type == ARG_GEN || type == ARG_GEN_BIG) {
430         // regs already saved by the heap check code
431         Sp_adj(-3);
432         Sp(2) = R1;
433         Sp(1) = size;
434         Sp(0) = stg_gc_fun_info;
435         // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
436         jump stg_gc_noregs [];
437     } else {
438         jump W_[stg_stack_save_entries + WDS(type)] [*]; // all regs live
439             // jumps to stg_gc_noregs after saving stuff
440     }
441 #endif /* !NO_ARG_REGS */
442 }
443
444
445 /* -----------------------------------------------------------------------------
446    Generic Apply (return point)
447
448    The dual to stg_fun_gc_gen (above): this fragment returns to the
449    function, passing arguments in the stack and in registers
450    appropriately.  The stack layout is given above.
451    -------------------------------------------------------------------------- */
452
453 INFO_TABLE_RET ( stg_gc_fun, RET_FUN )
454     /* explicit stack */
455 {
456     R1 = Sp(2);
457     Sp_adj(3);
458 #ifdef NO_ARG_REGS
459     // Minor optimisation: there are no argument registers to load up,
460     // so we can just jump straight to the function's entry point.
461     jump %GET_ENTRY(UNTAG(R1)) [R1];
462 #else
463     W_ info;
464     W_ type;
465
466     info = %GET_FUN_INFO(UNTAG(R1));
467     type = TO_W_(StgFunInfoExtra_fun_type(info));
468     if (type == ARG_GEN || type == ARG_GEN_BIG) {
469         jump StgFunInfoExtra_slow_apply(info) [R1];
470     } else {
471         if (type == ARG_BCO) {
472             // cover this case just to be on the safe side
473             Sp_adj(-2);
474             Sp(1) = R1;
475             Sp(0) = stg_apply_interp_info;
476             jump stg_yield_to_interpreter [];
477         } else {
478             jump W_[stg_ap_stack_entries + WDS(type)] [R1];
479         }
480     }
481 #endif
482 }
483
484 /* -----------------------------------------------------------------------------
485    Yields
486    -------------------------------------------------------------------------- */
487
488 stg_yield_noregs
489 {
490     YIELD_GENERIC;
491 }
492
493 /* -----------------------------------------------------------------------------
494    Yielding to the interpreter... top of stack says what to do next.
495    -------------------------------------------------------------------------- */
496
497 stg_yield_to_interpreter
498 {
499     YIELD_TO_INTERPRETER;
500 }
501
502 /* -----------------------------------------------------------------------------
503    Blocks
504    -------------------------------------------------------------------------- */
505
506 stg_block_noregs
507 {
508     BLOCK_GENERIC;
509 }
510
511 /* -----------------------------------------------------------------------------
512  * takeMVar/putMVar-specific blocks
513  *
514  * Stack layout for a thread blocked in takeMVar/readMVar:
515  *
516  *       ret. addr
517  *       ptr to MVar   (R1)
518  *       stg_block_takemvar_info (or stg_block_readmvar_info)
519  *
520  * Stack layout for a thread blocked in putMVar:
521  *
522  *       ret. addr
523  *       ptr to Value  (R2)
524  *       ptr to MVar   (R1)
525  *       stg_block_putmvar_info
526  *
527  * See PrimOps.hc for a description of the workings of take/putMVar.
528  *
529  * -------------------------------------------------------------------------- */
530
531 INFO_TABLE_RET ( stg_block_takemvar, RET_SMALL, W_ info_ptr, P_ mvar )
532     return ()
533 {
534     jump stg_takeMVarzh(mvar);
535 }
536
537 // code fragment executed just before we return to the scheduler
538 stg_block_takemvar_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_takemvar /* mvar passed in R1 */
550 {
551     Sp_adj(-2);
552     Sp(1) = R1;
553     Sp(0) = stg_block_takemvar_info;
554     R3 = R1; // mvar communicated to stg_block_takemvar_finally in R3
555     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
556 }
557
558 INFO_TABLE_RET ( stg_block_readmvar, RET_SMALL, W_ info_ptr, P_ mvar )
559     return ()
560 {
561     jump stg_readMVarzh(mvar);
562 }
563
564 // code fragment executed just before we return to the scheduler
565 stg_block_readmvar_finally
566 {
567     W_ r1, r3;
568     r1 = R1;
569     r3 = R3;
570     unlockClosure(R3, stg_MVAR_DIRTY_info);
571     R1 = r1;
572     R3 = r3;
573     jump StgReturn [R1];
574 }
575
576 stg_block_readmvar /* mvar passed in R1 */
577 {
578     Sp_adj(-2);
579     Sp(1) = R1;
580     Sp(0) = stg_block_readmvar_info;
581     R3 = R1; // mvar communicated to stg_block_readmvar_finally in R3
582     BLOCK_BUT_FIRST(stg_block_readmvar_finally);
583 }
584
585 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr,
586                 P_ mvar, P_ val )
587     return ()
588 {
589     jump stg_putMVarzh(mvar, val);
590 }
591
592 // code fragment executed just before we return to the scheduler
593 stg_block_putmvar_finally
594 {
595     W_ r1, r3;
596     r1 = R1;
597     r3 = R3;
598     unlockClosure(R3, stg_MVAR_DIRTY_info);
599     R1 = r1;
600     R3 = r3;
601     jump StgReturn [R1];
602 }
603
604 stg_block_putmvar (P_ mvar, P_ val)
605 {
606     push (stg_block_putmvar_info, mvar, val) {
607       R3 = R1; // mvar communicated to stg_block_putmvar_finally in R3
608       BLOCK_BUT_FIRST(stg_block_putmvar_finally);
609    }
610 }
611
612 stg_block_blackhole
613 {
614     Sp_adj(-2);
615     Sp(1) = R1;
616     Sp(0) = stg_enter_info;
617     BLOCK_GENERIC;
618 }
619
620 INFO_TABLE_RET ( stg_block_throwto, RET_SMALL, W_ info_ptr,
621                  P_ tso, P_ exception )
622     return ()
623 {
624     jump stg_killThreadzh(tso, exception);
625 }
626
627 stg_block_throwto_finally
628 {
629     // unlock the throwto message, but only if it wasn't already
630     // unlocked.  It may have been unlocked if we revoked the message
631     // due to an exception being raised during threadPaused().
632     if (StgHeader_info(StgTSO_block_info(CurrentTSO)) == stg_WHITEHOLE_info) {
633         W_ r1;
634         r1 = R1;
635         unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info);
636         R1 = r1;
637     }
638     jump StgReturn [R1];
639 }
640
641 stg_block_throwto (P_ tso, P_ exception)
642 {
643     push (stg_block_throwto_info, tso, exception) {
644        BLOCK_BUT_FIRST(stg_block_throwto_finally);
645     }
646 }
647
648 #ifdef mingw32_HOST_OS
649 INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares )
650     return ()
651 {
652     W_ len, errC;
653
654     len = TO_W_(StgAsyncIOResult_len(ares));
655     errC = TO_W_(StgAsyncIOResult_errCode(ares));
656     ccall free(ares "ptr");
657     return (len, errC);
658 }
659
660 stg_block_async
661 {
662     Sp_adj(-2);
663     Sp(0) = stg_block_async_info;
664     BLOCK_GENERIC;
665 }
666
667 /* Used by threadDelay implementation; it would be desirable to get rid of
668  * this free()'ing void return continuation.
669  */
670 INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares )
671     return ()
672 {
673     ccall free(ares "ptr");
674     return ();
675 }
676
677 stg_block_async_void
678 {
679     Sp_adj(-2);
680     Sp(0) = stg_block_async_void_info;
681     BLOCK_GENERIC;
682 }
683
684 #endif
685
686
687 /* -----------------------------------------------------------------------------
688    STM-specific waiting
689    -------------------------------------------------------------------------- */
690
691 stg_block_stmwait
692 {
693     // When blocking on an MVar we have to be careful to only release
694     // the lock on the MVar at the very last moment (using
695     // BLOCK_BUT_FIRST()), since when we release the lock another
696     // Capability can wake up the thread, which modifies its stack and
697     // other state.  This is not a problem for STM, because STM
698     // wakeups are non-destructive; the waker simply calls
699     // tryWakeupThread() which sends a message to the owner
700     // Capability.  So the moment we release this lock we might start
701     // getting wakeup messages, but that's perfectly harmless.
702     //
703     // Furthermore, we *must* release these locks, just in case an
704     // exception is raised in this thread by
705     // maybePerformBlockedException() while exiting to the scheduler,
706     // which will abort the transaction, which needs to obtain a lock
707     // on all the TVars to remove the thread from the queues.
708     //
709     ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
710     BLOCK_GENERIC;
711 }