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