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