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