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
  15 #ifdef __PIC__
  16 import pthread_mutex_unlock;
  17 #endif
  18 import EnterCriticalSection;
  19 import LeaveCriticalSection;
  20
  21 /* Stack/Heap Check Failure
  22  * ------------------------
  23  *
  24  * On discovering that a stack or heap check has failed, we do the following:
  25  *
  26  *    - If HpLim==0, indicating that we should context-switch, we yield
  27  *      to the scheduler (return ThreadYielding).
  28  *
  29  * Note that we must leave no slop in the heap (this is a requirement
  30  * for LDV profiling, at least), so if we just had a heap-check
  31  * failure, then we must retract Hp by HpAlloc.  How do we know
  32  * whether there was a heap-check failure?  HpLim might be zero, and
  33  * yet we got here as a result of a stack-check failure.  Hence, we
  34  * require that HpAlloc is only non-zero if there was a heap-check
  35  * failure, otherwise it is zero, so we can always safely subtract
  36  * HpAlloc from Hp.
  37  *
  38  * Hence, HpAlloc is zeroed in LOAD_THREAD_STATE().
  39  *
  40  *    - If the context_switch flag is set (the backup plan if setting HpLim
  41  *      to 0 didn't trigger a context switch), we yield to the scheduler
  42  *      (return ThreadYielding).
  43  *
  44  *    - If Hp > HpLim, we've had a heap check failure.  This means we've
  45  *      come to the end of the current heap block, so we try to chain
  46  *      another block on with ExtendNursery().
  47  *
  48  *           - If this succeeds, we carry on without returning to the
  49  *             scheduler.
  50  *
  51  *           - If it fails, we return to the scheduler claiming HeapOverflow
  52  *             so that a garbage collection can be performed.
  53  *
  54  *    - If Hp <= HpLim, it must have been a stack check that failed.  In
  55  *      which case, we return to the scheduler claiming StackOverflow, the
  56  *      scheduler will either increase the size of our stack, or raise
  57  *      an exception if the stack is already too big.
  58  *
  59  * The effect of checking for context switch only in the heap/stack check
  60  * failure code is that we'll switch threads after the current thread has
  61  * reached the end of its heap block.  If a thread isn't allocating
  62  * at all, it won't yield.  Hopefully this won't be a problem in practice.
  63  */
  64
  65 #define PRE_RETURN(why,what_next)                       \
  66   StgTSO_what_next(CurrentTSO) = what_next::I16;        \
  67   StgRegTable_rRet(BaseReg) = why;                      \
  68   R1 = BaseReg;
  69
  70 /* Remember that the return address is *removed* when returning to a
  71  * ThreadRunGHC thread.
  72  */
  73
  74 #define GC_GENERIC                                              \
  75     DEBUG_ONLY(foreign "C" heapCheckFail());                    \
  76     if (Hp > HpLim) {                                           \
  77         Hp = Hp - HpAlloc/*in bytes*/;                          \
  78         if (HpLim == 0) { \
  79                 R1 = ThreadYielding;                            \
  80                 goto sched;                                     \
  81         }                                               \
  82         if (HpAlloc <= BLOCK_SIZE                               \
  83             && bdescr_link(CurrentNursery) != NULL) {           \
  84             HpAlloc = 0;                                        \
  85             CLOSE_NURSERY();                                    \
  86             CurrentNursery = bdescr_link(CurrentNursery);       \
  87             OPEN_NURSERY();                                     \
  88             if (Capability_context_switch(MyCapability()) != 0 :: CInt) { \
  89                 R1 = ThreadYielding;                            \
  90                 goto sched;                                     \
  91             } else {                                            \
  92                 jump %ENTRY_CODE(Sp(0));                        \
  93             }                                                   \
  94         } else {                                                \
  95             R1 = HeapOverflow;                                  \
  96             goto sched;                                         \
  97         }                                                       \
  98     } else {                                                    \
  99         R1 = StackOverflow;                                     \
 100     }                                                           \
 101   sched:                                                        \
 102     PRE_RETURN(R1,ThreadRunGHC);                                \
 103     jump stg_returnToSched;
 104
 105 #define HP_GENERIC                              \
 106    PRE_RETURN(HeapOverflow, ThreadRunGHC)       \
 107   jump stg_returnToSched;
 108
 109 #define BLOCK_GENERIC                           \
 110    PRE_RETURN(ThreadBlocked,  ThreadRunGHC)     \
 111   jump stg_returnToSched;
 112
 113 #define YIELD_GENERIC                           \
 114   PRE_RETURN(ThreadYielding, ThreadRunGHC)      \
 115   jump stg_returnToSched;
 116
 117 #define BLOCK_BUT_FIRST(c)                      \
 118   PRE_RETURN(ThreadBlocked, ThreadRunGHC)       \
 119   R2 = c;                                       \
 120   jump stg_returnToSchedButFirst;
 121
 122 #define YIELD_TO_INTERPRETER                    \
 123   PRE_RETURN(ThreadYielding, ThreadInterpret)   \
 124   jump stg_returnToSchedNotPaused;
 125
 126 /* -----------------------------------------------------------------------------
 127    Heap checks in thunks/functions.
 128
 129    In these cases, node always points to the function closure.  This gives
 130    us an easy way to return to the function: just leave R1 on the top of
 131    the stack, and have the scheduler enter it to return.
 132
 133    There are canned sequences for 'n' pointer values in registers.
 134    -------------------------------------------------------------------------- */
 135
 136 INFO_TABLE_RET( stg_enter, RET_SMALL, P_ unused)
 137 {
 138     R1 = Sp(1);
 139     Sp_adj(2);
 140     ENTER();
 141 }
 142
 143 __stg_gc_enter_1
 144 {
 145     Sp_adj(-2);
 146     Sp(1) = R1;
 147     Sp(0) = stg_enter_info;
 148     GC_GENERIC
 149 }
 150
 151 /* -----------------------------------------------------------------------------
 152    Heap checks in Primitive case alternatives
 153
 154    A primitive case alternative is entered with a value either in
 155    R1, FloatReg1 or D1 depending on the return convention.  All the
 156    cases are covered below.
 157    -------------------------------------------------------------------------- */
 158
 159 /*-- No Registers live ------------------------------------------------------ */
 160
 161 stg_gc_noregs
 162 {
 163     GC_GENERIC
 164 }
 165
 166 /*-- void return ------------------------------------------------------------ */
 167
 168 INFO_TABLE_RET( stg_gc_void, RET_SMALL)
 169 {
 170     Sp_adj(1);
 171     jump %ENTRY_CODE(Sp(0));
 172 }
 173
 174 /*-- R1 is boxed/unpointed -------------------------------------------------- */
 175
 176 INFO_TABLE_RET( stg_gc_unpt_r1, RET_SMALL, P_ unused)
 177 {
 178     R1 = Sp(1);
 179     Sp_adj(2);
 180     jump %ENTRY_CODE(Sp(0));
 181 }
 182
 183 stg_gc_unpt_r1
 184 {
 185     Sp_adj(-2);
 186     Sp(1) = R1;
 187     Sp(0) = stg_gc_unpt_r1_info;
 188     GC_GENERIC
 189 }
 190
 191 /*-- R1 is unboxed -------------------------------------------------- */
 192
 193 /* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
 194 INFO_TABLE_RET( stg_gc_unbx_r1, RET_SMALL, W_ unused )
 195 {
 196     R1 = Sp(1);
 197     Sp_adj(2);
 198     jump %ENTRY_CODE(Sp(0));
 199 }
 200
 201 stg_gc_unbx_r1
 202 {
 203     Sp_adj(-2);
 204     Sp(1) = R1;
 205     Sp(0) = stg_gc_unbx_r1_info;
 206     GC_GENERIC
 207 }
 208
 209 /*-- F1 contains a float ------------------------------------------------- */
 210
 211 INFO_TABLE_RET( stg_gc_f1, RET_SMALL, F_ unused )
 212 {
 213     F1 = F_[Sp+WDS(1)];
 214     Sp_adj(2);
 215     jump %ENTRY_CODE(Sp(0));
 216 }
 217
 218 stg_gc_f1
 219 {
 220     Sp_adj(-2);
 221     F_[Sp + WDS(1)] = F1;
 222     Sp(0) = stg_gc_f1_info;
 223     GC_GENERIC
 224 }
 225
 226 /*-- D1 contains a double ------------------------------------------------- */
 227
 228 INFO_TABLE_RET( stg_gc_d1, RET_SMALL, D_ unused )
 229 {
 230     D1 = D_[Sp + WDS(1)];
 231     Sp = Sp + WDS(1) + SIZEOF_StgDouble;
 232     jump %ENTRY_CODE(Sp(0));
 233 }
 234
 235 stg_gc_d1
 236 {
 237     Sp = Sp - WDS(1) - SIZEOF_StgDouble;
 238     D_[Sp + WDS(1)] = D1;
 239     Sp(0) = stg_gc_d1_info;
 240     GC_GENERIC
 241 }
 242
 243
 244 /*-- L1 contains an int64 ------------------------------------------------- */
 245
 246 INFO_TABLE_RET( stg_gc_l1, RET_SMALL, L_ unused )
 247 {
 248     L1 = L_[Sp + WDS(1)];
 249     Sp_adj(1) + SIZEOF_StgWord64;
 250     jump %ENTRY_CODE(Sp(0));
 251 }
 252
 253 stg_gc_l1
 254 {
 255     Sp_adj(-1) - SIZEOF_StgWord64;
 256     L_[Sp + WDS(1)] = L1;
 257     Sp(0) = stg_gc_l1_info;
 258     GC_GENERIC
 259 }
 260
 261 /*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */
 262
 263 INFO_TABLE_RET( stg_ut_1_0_unreg, RET_SMALL, P_ unused )
 264 {
 265     Sp_adj(1);
 266     // one ptr is on the stack (Sp(0))
 267     jump %ENTRY_CODE(Sp(1));
 268 }
 269
 270 /* -----------------------------------------------------------------------------
 271    Generic function entry heap check code.
 272
 273    At a function entry point, the arguments are as per the calling convention,
 274    i.e. some in regs and some on the stack.  There may or may not be
 275    a pointer to the function closure in R1 - if there isn't, then the heap
 276    check failure code in the function will arrange to load it.
 277
 278    The function's argument types are described in its info table, so we
 279    can just jump to this bit of generic code to save away all the
 280    registers and return to the scheduler.
 281
 282    This code arranges the stack like this:
 283
 284          |        ....         |
 285          |        args         |
 286          +---------------------+
 287          |      f_closure      |
 288          +---------------------+
 289          |        size         |
 290          +---------------------+
 291          |   stg_gc_fun_info   |
 292          +---------------------+
 293
 294    The size is the number of words of arguments on the stack, and is cached
 295    in the frame in order to simplify stack walking: otherwise the size of
 296    this stack frame would have to be calculated by looking at f's info table.
 297
 298    -------------------------------------------------------------------------- */
 299
 300 __stg_gc_fun
 301 {
 302     W_ size;
 303     W_ info;
 304     W_ type;
 305
 306     info = %GET_FUN_INFO(UNTAG(R1));
 307
 308     // cache the size
 309     type = TO_W_(StgFunInfoExtra_fun_type(info));
 310     if (type == ARG_GEN) {
 311         size = BITMAP_SIZE(StgFunInfoExtra_bitmap(info));
 312     } else {
 313         if (type == ARG_GEN_BIG) {
 314 #ifdef TABLES_NEXT_TO_CODE
 315             // bitmap field holds an offset
 316             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info)
 317                                         + %GET_ENTRY(UNTAG(R1)) /* ### */ );
 318 #else
 319             size = StgLargeBitmap_size( StgFunInfoExtra_bitmap(info) );
 320 #endif
 321         } else {
 322             size = BITMAP_SIZE(W_[stg_arg_bitmaps + WDS(type)]);
 323         }
 324     }
 325
 326 #ifdef NO_ARG_REGS
 327     // we don't have to save any registers away
 328     Sp_adj(-3);
 329     Sp(2) = R1;
 330     Sp(1) = size;
 331     Sp(0) = stg_gc_fun_info;
 332     GC_GENERIC
 333 #else
 334     W_ type;
 335     type = TO_W_(StgFunInfoExtra_fun_type(info));
 336     // cache the size
 337     if (type == ARG_GEN || type == ARG_GEN_BIG) {
 338         // regs already saved by the heap check code
 339         Sp_adj(-3);
 340         Sp(2) = R1;
 341         Sp(1) = size;
 342         Sp(0) = stg_gc_fun_info;
 343         // DEBUG_ONLY(foreign "C" debugBelch("stg_fun_gc_gen(ARG_GEN)"););
 344         GC_GENERIC
 345     } else {
 346         jump W_[stg_stack_save_entries + WDS(type)];
 347             // jumps to stg_gc_noregs after saving stuff
 348     }
 349 #endif /* !NO_ARG_REGS */
 350 }
 351
 352 /* -----------------------------------------------------------------------------
 353    Generic Apply (return point)
 354
 355    The dual to stg_fun_gc_gen (above): this fragment returns to the
 356    function, passing arguments in the stack and in registers
 357    appropriately.  The stack layout is given above.
 358    -------------------------------------------------------------------------- */
 359
 360 INFO_TABLE_RET( stg_gc_fun, RET_FUN )
 361 {
 362     R1 = Sp(2);
 363     Sp_adj(3);
 364 #ifdef NO_ARG_REGS
 365     // Minor optimisation: there are no argument registers to load up,
 366     // so we can just jump straight to the function's entry point.
 367     jump %GET_ENTRY(UNTAG(R1));
 368 #else
 369     W_ info;
 370     W_ type;
 371
 372     info = %GET_FUN_INFO(UNTAG(R1));
 373     type = TO_W_(StgFunInfoExtra_fun_type(info));
 374     if (type == ARG_GEN || type == ARG_GEN_BIG) {
 375         jump StgFunInfoExtra_slow_apply(info);
 376     } else {
 377         if (type == ARG_BCO) {
 378             // cover this case just to be on the safe side
 379             Sp_adj(-2);
 380             Sp(1) = R1;
 381             Sp(0) = stg_apply_interp_info;
 382             jump stg_yield_to_interpreter;
 383         } else {
 384             jump W_[stg_ap_stack_entries + WDS(type)];
 385         }
 386     }
 387 #endif
 388 }
 389
 390 /* -----------------------------------------------------------------------------
 391    Generic Heap Check Code.
 392
 393    Called with Liveness mask in R9,  Return address in R10.
 394    Stack must be consistent (containing all necessary info pointers
 395    to relevant SRTs).
 396
 397    See StgMacros.h for a description of the RET_DYN stack frame.
 398
 399    We also define an stg_gen_yield here, because it's very similar.
 400    -------------------------------------------------------------------------- */
 401
 402 // For simplicity, we assume that SIZEOF_DOUBLE == 2*SIZEOF_VOID_P
 403 // on a 64-bit machine, we'll end up wasting a couple of words, but
 404 // it's not a big deal.
 405
 406 #define RESTORE_EVERYTHING                      \
 407     L1   = L_[Sp + WDS(19)];                    \
 408     D2   = D_[Sp + WDS(17)];                    \
 409     D1   = D_[Sp + WDS(15)];                    \
 410     F4   = F_[Sp + WDS(14)];                    \
 411     F3   = F_[Sp + WDS(13)];                    \
 412     F2   = F_[Sp + WDS(12)];                    \
 413     F1   = F_[Sp + WDS(11)];                    \
 414     R8 = Sp(10);                                \
 415     R7 = Sp(9);                                 \
 416     R6 = Sp(8);                                 \
 417     R5 = Sp(7);                                 \
 418     R4 = Sp(6);                                 \
 419     R3 = Sp(5);                                 \
 420     R2 = Sp(4);                                 \
 421     R1 = Sp(3);                                 \
 422     Sp_adj(21);
 423
 424 #define RET_OFFSET (-19)
 425
 426 #define SAVE_EVERYTHING                         \
 427     Sp_adj(-21);                                \
 428     L_[Sp + WDS(19)] = L1;                      \
 429     D_[Sp + WDS(17)] = D2;                      \
 430     D_[Sp + WDS(15)] = D1;                      \
 431     F_[Sp + WDS(14)] = F4;                      \
 432     F_[Sp + WDS(13)] = F3;                      \
 433     F_[Sp + WDS(12)] = F2;                      \
 434     F_[Sp + WDS(11)] = F1;                      \
 435     Sp(10) = R8;                                \
 436     Sp(9) = R7;                                 \
 437     Sp(8) = R6;                                 \
 438     Sp(7) = R5;                                 \
 439     Sp(6) = R4;                                 \
 440     Sp(5) = R3;                                 \
 441     Sp(4) = R2;                                 \
 442     Sp(3) = R1;                                 \
 443     Sp(2) = R10;    /* return address */        \
 444     Sp(1) = R9;     /* liveness mask  */        \
 445     Sp(0) = stg_gc_gen_info;
 446
 447 INFO_TABLE_RET( stg_gc_gen, RET_DYN )
 448 /* bitmap in the above info table is unused, the real one is on the stack. */
 449 {
 450     RESTORE_EVERYTHING;
 451     jump Sp(RET_OFFSET); /* No %ENTRY_CODE( - this is an actual code ptr */
 452 }
 453
 454 stg_gc_gen
 455 {
 456     SAVE_EVERYTHING;
 457     GC_GENERIC
 458 }
 459
 460 // A heap check at an unboxed tuple return point.  The return address
 461 // is on the stack, and we can find it by using the offsets given
 462 // to us in the liveness mask.
 463 stg_gc_ut
 464 {
 465     R10 = %ENTRY_CODE(Sp(RET_DYN_NONPTRS(R9) + RET_DYN_PTRS(R9)));
 466     SAVE_EVERYTHING;
 467     GC_GENERIC
 468 }
 469
 470 /*
 471  * stg_gen_hp is used by MAYBE_GC, where we can't use GC_GENERIC
 472  * because we've just failed doYouWantToGC(), not a standard heap
 473  * check.  GC_GENERIC would end up returning StackOverflow.
 474  */
 475 stg_gc_gen_hp
 476 {
 477     SAVE_EVERYTHING;
 478     HP_GENERIC
 479 }
 480
 481 /* -----------------------------------------------------------------------------
 482    Yields
 483    -------------------------------------------------------------------------- */
 484
 485 stg_gen_yield
 486 {
 487     SAVE_EVERYTHING;
 488     YIELD_GENERIC
 489 }
 490
 491 stg_yield_noregs
 492 {
 493     YIELD_GENERIC;
 494 }
 495
 496 /* -----------------------------------------------------------------------------
 497    Yielding to the interpreter... top of stack says what to do next.
 498    -------------------------------------------------------------------------- */
 499
 500 stg_yield_to_interpreter
 501 {
 502     YIELD_TO_INTERPRETER;
 503 }
 504
 505 /* -----------------------------------------------------------------------------
 506    Blocks
 507    -------------------------------------------------------------------------- */
 508
 509 stg_gen_block
 510 {
 511     SAVE_EVERYTHING;
 512     BLOCK_GENERIC;
 513 }
 514
 515 stg_block_noregs
 516 {
 517     BLOCK_GENERIC;
 518 }
 519
 520 stg_block_1
 521 {
 522     Sp_adj(-2);
 523     Sp(1) = R1;
 524     Sp(0) = stg_enter_info;
 525     BLOCK_GENERIC;
 526 }
 527
 528 /* -----------------------------------------------------------------------------
 529  * takeMVar/putMVar-specific blocks
 530  *
 531  * Stack layout for a thread blocked in takeMVar:
 532  *
 533  *       ret. addr
 534  *       ptr to MVar   (R1)
 535  *       stg_block_takemvar_info
 536  *
 537  * Stack layout for a thread blocked in putMVar:
 538  *
 539  *       ret. addr
 540  *       ptr to Value  (R2)
 541  *       ptr to MVar   (R1)
 542  *       stg_block_putmvar_info
 543  *
 544  * See PrimOps.hc for a description of the workings of take/putMVar.
 545  *
 546  * -------------------------------------------------------------------------- */
 547
 548 INFO_TABLE_RET( stg_block_takemvar, RET_SMALL, P_ unused )
 549 {
 550     R1 = Sp(1);
 551     Sp_adj(2);
 552     jump stg_takeMVarzh;
 553 }
 554
 555 // code fragment executed just before we return to the scheduler
 556 stg_block_takemvar_finally
 557 {
 558 #ifdef THREADED_RTS
 559     unlockClosure(R3, stg_MVAR_DIRTY_info);
 560 #else
 561     SET_INFO(R3, stg_MVAR_DIRTY_info);
 562 #endif
 563     jump StgReturn;
 564 }
 565
 566 stg_block_takemvar
 567 {
 568     Sp_adj(-2);
 569     Sp(1) = R1;
 570     Sp(0) = stg_block_takemvar_info;
 571     R3 = R1;
 572     BLOCK_BUT_FIRST(stg_block_takemvar_finally);
 573 }
 574
 575 INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, P_ unused1, P_ unused2 )
 576 {
 577     R2 = Sp(2);
 578     R1 = Sp(1);
 579     Sp_adj(3);
 580     jump stg_putMVarzh;
 581 }
 582
 583 // code fragment executed just before we return to the scheduler
 584 stg_block_putmvar_finally
 585 {
 586 #ifdef THREADED_RTS
 587     unlockClosure(R3, stg_MVAR_DIRTY_info);
 588 #else
 589     SET_INFO(R3, stg_MVAR_DIRTY_info);
 590 #endif
 591     jump StgReturn;
 592 }
 593
 594 stg_block_putmvar
 595 {
 596     Sp_adj(-3);
 597     Sp(2) = R2;
 598     Sp(1) = R1;
 599     Sp(0) = stg_block_putmvar_info;
 600     R3 = R1;
 601     BLOCK_BUT_FIRST(stg_block_putmvar_finally);
 602 }
 603
 604 // code fragment executed just before we return to the scheduler
 605 stg_block_blackhole_finally
 606 {
 607 #if defined(THREADED_RTS)
 608     // The last thing we do is release sched_lock, which is
 609     // preventing other threads from accessing blackhole_queue and
 610     // picking up this thread before we are finished with it.
 611     RELEASE_LOCK(sched_mutex "ptr");
 612 #endif
 613     jump StgReturn;
 614 }
 615
 616 stg_block_blackhole
 617 {
 618     Sp_adj(-2);
 619     Sp(1) = R1;
 620     Sp(0) = stg_enter_info;
 621     BLOCK_BUT_FIRST(stg_block_blackhole_finally);
 622 }
 623
 624 INFO_TABLE_RET( stg_block_throwto, RET_SMALL, P_ unused, P_ unused )
 625 {
 626     R2 = Sp(2);
 627     R1 = Sp(1);
 628     Sp_adj(3);
 629     jump stg_killThreadzh;
 630 }
 631
 632 stg_block_throwto_finally
 633 {
 634     // unlock the throwto message
 635     unlockClosure(StgTSO_block_info(CurrentTSO), stg_MSG_THROWTO_info);
 636     jump StgReturn;
 637 }
 638
 639 stg_block_throwto
 640 {
 641     Sp_adj(-3);
 642     Sp(2) = R2;
 643     Sp(1) = R1;
 644     Sp(0) = stg_block_throwto_info;
 645     BLOCK_BUT_FIRST(stg_block_throwto_finally);
 646 }
 647
 648 #ifdef mingw32_HOST_OS
 649 INFO_TABLE_RET( stg_block_async, RET_SMALL )
 650 {
 651     W_ ares;
 652     W_ len, errC;
 653
 654     ares = StgTSO_block_info(CurrentTSO);
 655     len = StgAsyncIOResult_len(ares);
 656     errC = StgAsyncIOResult_errCode(ares);
 657     StgTSO_block_info(CurrentTSO) = NULL;
 658     foreign "C" free(ares "ptr");
 659     R1 = len;
 660     Sp(0) = errC;
 661     jump %ENTRY_CODE(Sp(1));
 662 }
 663
 664 stg_block_async
 665 {
 666     Sp_adj(-1);
 667     Sp(0) = stg_block_async_info;
 668     BLOCK_GENERIC;
 669 }
 670
 671 /* Used by threadDelay implementation; it would be desirable to get rid of
 672  * this free()'ing void return continuation.
 673  */
 674 INFO_TABLE_RET( stg_block_async_void, RET_SMALL )
 675 {
 676     W_ ares;
 677
 678     ares = StgTSO_block_info(CurrentTSO);
 679     StgTSO_block_info(CurrentTSO) = NULL;
 680     foreign "C" free(ares "ptr");
 681     Sp_adj(1);
 682     jump %ENTRY_CODE(Sp(0));
 683 }
 684
 685 stg_block_async_void
 686 {
 687     Sp_adj(-1);
 688     Sp(0) = stg_block_async_void_info;
 689     BLOCK_GENERIC;
 690 }
 691
 692 #endif
 693
 694 /* -----------------------------------------------------------------------------
 695    STM-specific waiting
 696    -------------------------------------------------------------------------- */
 697
 698 stg_block_stmwait_finally
 699 {
 700     foreign "C" stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
 701     jump StgReturn;
 702 }
 703
 704 stg_block_stmwait
 705 {
 706     BLOCK_BUT_FIRST(stg_block_stmwait_finally);
 707 }