Fix histograms for ticky code
[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(
409                       TO_W_(StgFunInfoExtraRev_bitmap_offset(info))
410                       + %GET_ENTRY(UNTAG(R1)) /* ### */ );
411 #else
412             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
413 #endif
414         } else {
415             size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
416         }
417     }
418
419 #ifdef NO_ARG_REGS
420     // we don't have to save any registers away
421     Sp_adj(-3);
422     Sp(2) = R1;
423     Sp(1) = size;
424     Sp(0) = stg_gc_fun_info;
425     jump stg_gc_noregs [];
426 #else
427     W_ type;
428     type = TO_W_(StgFunInfoExtra_fun_type(info));
429     // cache the size
430     if (type == ARG_GEN || type == ARG_GEN_BIG) {
431         // regs already saved by the heap check code
432         Sp_adj(-3);
433         Sp(2) = R1;
434         Sp(1) = size;
435         Sp(0) = stg_gc_fun_info;
436         // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
437         jump stg_gc_noregs [];
438     } else {
439         jump W_[stg_stack_save_entries + WDS(type)] [*]; // all regs live
440             // jumps to stg_gc_noregs after saving stuff
441     }
442 #endif /* !NO_ARG_REGS */
443 }
444
445
446 /* -----------------------------------------------------------------------------
447    Generic Apply (return point)
448
449    The dual to stg_fun_gc_gen (above): this fragment returns to the
450    function, passing arguments in the stack and in registers
451    appropriately.  The stack layout is given above.
452    -------------------------------------------------------------------------- */
453
454 INFO_TABLE_RET ( stg_gc_fun, RET_FUN )
455     /* explicit stack */
456 {
457     R1 = Sp(2);
458     Sp_adj(3);
459 #ifdef NO_ARG_REGS
460     // Minor optimisation: there are no argument registers to load up,
461     // so we can just jump straight to the function's entry point.
462     jump %GET_ENTRY(UNTAG(R1)) [R1];
463 #else
464     W_ info;
465     W_ type;
466
467     info = %GET_FUN_INFO(UNTAG(R1));
468     type = TO_W_(StgFunInfoExtra_fun_type(info));
469     if (type == ARG_GEN || type == ARG_GEN_BIG) {
470         jump StgFunInfoExtra_slow_apply(info) [R1];
471     } else {
472         if (type == ARG_BCO) {
473             // cover this case just to be on the safe side
474             Sp_adj(-2);
475             Sp(1) = R1;
476             Sp(0) = stg_apply_interp_info;
477             jump stg_yield_to_interpreter [];
478         } else {
479             jump W_[stg_ap_stack_entries + WDS(type)] [R1];
480         }
481     }
482 #endif
483 }
484
485 /* -----------------------------------------------------------------------------
486    Yields
487    -------------------------------------------------------------------------- */
488
489 stg_yield_noregs
490 {
491     YIELD_GENERIC;
492 }
493
494 /* -----------------------------------------------------------------------------
495    Yielding to the interpreter... top of stack says what to do next.
496    -------------------------------------------------------------------------- */
497
498 stg_yield_to_interpreter
499 {
500     YIELD_TO_INTERPRETER;
501 }
502
503 /* -----------------------------------------------------------------------------
504    Blocks
505    -------------------------------------------------------------------------- */
506
507 stg_block_noregs
508 {
509     BLOCK_GENERIC;
510 }
511
512 /* -----------------------------------------------------------------------------
513  * takeMVar/putMVar-specific blocks
514  *
515  * Stack layout for a thread blocked in takeMVar/readMVar:
516  *
517  *       ret. addr
518  *       ptr to MVar   (R1)
519  *       stg_block_takemvar_info (or stg_block_readmvar_info)
520  *
521  * Stack layout for a thread blocked in putMVar:
522  *
523  *       ret. addr
524  *       ptr to Value  (R2)
525  *       ptr to MVar   (R1)
526  *       stg_block_putmvar_info
527  *
528  * See PrimOps.hc for a description of the workings of take/putMVar.
529  *
530  * -------------------------------------------------------------------------- */
531
532 INFO_TABLE_RET ( stg_block_takemvar, RET_SMALL, W_ info_ptr, P_ mvar )
533     return ()
534 {
535     jump stg_takeMVarzh(mvar);
536 }
537
538 // code fragment executed just before we return to the scheduler
539 stg_block_takemvar_finally
540 {
541     W_ r1, r3;
542     r1 = R1;
543     r3 = R3;
544     unlockClosure(R3, stg_MVAR_DIRTY_info);
545     R1 = r1;
546     R3 = r3;
547     jump StgReturn [R1];
548 }
549
550 stg_block_takemvar /* mvar passed in R1 */
551 {
552     Sp_adj(-2);
553     Sp(1) = R1;
554     Sp(0) = stg_block_takemvar_info;
555     R3 = R1; // mvar communicated to stg_block_takemvar_finally in R3
556     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
557 }
558
559 INFO_TABLE_RET ( stg_block_readmvar, RET_SMALL, W_ info_ptr, P_ mvar )
560     return ()
561 {
562     jump stg_readMVarzh(mvar);
563 }
564
565 // code fragment executed just before we return to the scheduler
566 stg_block_readmvar_finally
567 {
568     W_ r1, r3;
569     r1 = R1;
570     r3 = R3;
571     unlockClosure(R3, stg_MVAR_DIRTY_info);
572     R1 = r1;
573     R3 = r3;
574     jump StgReturn [R1];
575 }
576
577 stg_block_readmvar /* mvar passed in R1 */
578 {
579     Sp_adj(-2);
580     Sp(1) = R1;
581     Sp(0) = stg_block_readmvar_info;
582     R3 = R1; // mvar communicated to stg_block_readmvar_finally in R3
583     BLOCK_BUT_FIRST(stg_block_readmvar_finally);
584 }
585
586 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr,
587                 P_ mvar, P_ val )
588     return ()
589 {
590     jump stg_putMVarzh(mvar, val);
591 }
592
593 // code fragment executed just before we return to the scheduler
594 stg_block_putmvar_finally
595 {
596     W_ r1, r3;
597     r1 = R1;
598     r3 = R3;
599     unlockClosure(R3, stg_MVAR_DIRTY_info);
600     R1 = r1;
601     R3 = r3;
602     jump StgReturn [R1];
603 }
604
605 stg_block_putmvar (P_ mvar, P_ val)
606 {
607     push (stg_block_putmvar_info, mvar, val) {
608       R3 = R1; // mvar communicated to stg_block_putmvar_finally in R3
609       BLOCK_BUT_FIRST(stg_block_putmvar_finally);
610    }
611 }
612
613 stg_block_blackhole (P_ node)
614 {
615     Sp_adj(-2);
616     Sp(1) = node;
617     Sp(0) = stg_enter_info;
618     BLOCK_GENERIC;
619 }
620
621 INFO_TABLE_RET ( stg_block_throwto, RET_SMALL, W_ info_ptr,
622                  P_ tso, P_ exception )
623     return ()
624 {
625     jump stg_killThreadzh(tso, exception);
626 }
627
628 stg_block_throwto_finally
629 {
630     // unlock the throwto message, but only if it wasn't already
631     // unlocked.  It may have been unlocked if we revoked the message
632     // due to an exception being raised during threadPaused().
633     if (StgHeader_info(StgTSO_block_info(CurrentTSO)) == stg_WHITEHOLE_info) {
634         W_ r1;
635         r1 = R1;
636         unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info);
637         R1 = r1;
638     }
639     jump StgReturn [R1];
640 }
641
642 stg_block_throwto (P_ tso, P_ exception)
643 {
644     push (stg_block_throwto_info, tso, exception) {
645        BLOCK_BUT_FIRST(stg_block_throwto_finally);
646     }
647 }
648
649 #ifdef mingw32_HOST_OS
650 INFO_TABLE_RET ( stg_block_async, RET_SMALL, W_ info_ptr, W_ ares )
651     return ()
652 {
653     W_ len, errC;
654
655     len = TO_W_(StgAsyncIOResult_len(ares));
656     errC = TO_W_(StgAsyncIOResult_errCode(ares));
657     ccall free(ares "ptr");
658     return (len, errC);
659 }
660
661 stg_block_async
662 {
663     Sp_adj(-2);
664     Sp(0) = stg_block_async_info;
665     BLOCK_GENERIC;
666 }
667
668 /* Used by threadDelay implementation; it would be desirable to get rid of
669  * this free()'ing void return continuation.
670  */
671 INFO_TABLE_RET ( stg_block_async_void, RET_SMALL, W_ info_ptr, W_ ares )
672     return ()
673 {
674     ccall free(ares "ptr");
675     return ();
676 }
677
678 stg_block_async_void
679 {
680     Sp_adj(-2);
681     Sp(0) = stg_block_async_void_info;
682     BLOCK_GENERIC;
683 }
684
685 #endif
686
687
688 /* -----------------------------------------------------------------------------
689    STM-specific waiting
690    -------------------------------------------------------------------------- */
691
692 stg_block_stmwait
693 {
694     // When blocking on an MVar we have to be careful to only release
695     // the lock on the MVar at the very last moment (using
696     // BLOCK_BUT_FIRST()), since when we release the lock another
697     // Capability can wake up the thread, which modifies its stack and
698     // other state.  This is not a problem for STM, because STM
699     // wakeups are non-destructive; the waker simply calls
700     // tryWakeupThread() which sends a message to the owner
701     // Capability.  So the moment we release this lock we might start
702     // getting wakeup messages, but that's perfectly harmless.
703     //
704     // Furthermore, we *must* release these locks, just in case an
705     // exception is raised in this thread by
706     // maybePerformBlockedException() while exiting to the scheduler,
707     // which will abort the transaction, which needs to obtain a lock
708     // on all the TVars to remove the thread from the queues.
709     //
710     ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
711     BLOCK_GENERIC;
712 }