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