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