rts/PrimOps.cmm

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2011
   4  *
   5  * Out-of-line primitive operations
   6  *
   7  * This file contains the implementations of all the primitive
   8  * operations ("primops") which are not expanded inline.  See
   9  * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
  10  * this file contains code for most of those with the attribute
  11  * out_of_line=True.
  12  *
  13  * Entry convention: the entry convention for a primop is that all the
  14  * args are in Stg registers (R1, R2, etc.).  This is to make writing
  15  * the primops easier.  (see compiler/codeGen/CgCallConv.hs).
  16  *
  17  * Return convention: results from a primop are generally returned
  18  * using the ordinary unboxed tuple return convention.  The C-- parser
  19  * implements the RET_xxxx() macros to perform unboxed-tuple returns
  20  * based on the prevailing return convention.
  21  *
  22  * This file is written in a subset of C--, extended with various
  23  * features specific to GHC.  It is compiled by GHC directly.  For the
  24  * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
  25  *
  26  * ---------------------------------------------------------------------------*/
  27
  28 #include "Cmm.h"
  29
  30 #ifdef __PIC__
  31 import pthread_mutex_lock;
  32 import pthread_mutex_unlock;
  33 #endif
  34 import base_ControlziExceptionziBase_nestedAtomically_closure;
  35 import EnterCriticalSection;
  36 import LeaveCriticalSection;
  37 import ghczmprim_GHCziTypes_False_closure;
  38 #if !defined(mingw32_HOST_OS)
  39 import sm_mutex;
  40 #endif
  41
  42 /*-----------------------------------------------------------------------------
  43   Array Primitives
  44
  45   Basically just new*Array - the others are all inline macros.
  46
  47   The size arg is always passed in R1, and the result returned in R1.
  48
  49   The slow entry point is for returning from a heap check, the saved
  50   size argument must be re-loaded from the stack.
  51   -------------------------------------------------------------------------- */
  52
  53 /* for objects that are *less* than the size of a word, make sure we
  54  * round up to the nearest word for the size of the array.
  55  */
  56
  57 stg_newByteArrayzh
  58 {
  59     W_ words, payload_words, n, p;
  60     MAYBE_GC(NO_PTRS,stg_newByteArrayzh);
  61     n = R1;
  62     payload_words = ROUNDUP_BYTES_TO_WDS(n);
  63     words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
  64     ("ptr" p) = foreign "C" allocate(MyCapability() "ptr",words) [];
  65     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
  66     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
  67     StgArrWords_bytes(p) = n;
  68     RET_P(p);
  69 }
  70
  71 #define BA_ALIGN 16
  72 #define BA_MASK  (BA_ALIGN-1)
  73
  74 stg_newPinnedByteArrayzh
  75 {
  76     W_ words, n, bytes, payload_words, p;
  77
  78     MAYBE_GC(NO_PTRS,stg_newPinnedByteArrayzh);
  79     n = R1;
  80     bytes = n;
  81     /* payload_words is what we will tell the profiler we had to allocate */
  82     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
  83     /* When we actually allocate memory, we need to allow space for the
  84        header: */
  85     bytes = bytes + SIZEOF_StgArrWords;
  86     /* And we want to align to BA_ALIGN bytes, so we need to allow space
  87        to shift up to BA_ALIGN - 1 bytes: */
  88     bytes = bytes + BA_ALIGN - 1;
  89     /* Now we convert to a number of words: */
  90     words = ROUNDUP_BYTES_TO_WDS(bytes);
  91
  92     ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
  93     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
  94
  95     /* Now we need to move p forward so that the payload is aligned
  96        to BA_ALIGN bytes: */
  97     p = p + ((-p - SIZEOF_StgArrWords) & BA_MASK);
  98
  99     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 100     StgArrWords_bytes(p) = n;
 101     RET_P(p);
 102 }
 103
 104 stg_newAlignedPinnedByteArrayzh
 105 {
 106     W_ words, n, bytes, payload_words, p, alignment;
 107
 108     MAYBE_GC(NO_PTRS,stg_newAlignedPinnedByteArrayzh);
 109     n = R1;
 110     alignment = R2;
 111
 112     /* we always supply at least word-aligned memory, so there's no
 113        need to allow extra space for alignment if the requirement is less
 114        than a word.  This also prevents mischief with alignment == 0. */
 115     if (alignment <= SIZEOF_W) { alignment = 1; }
 116
 117     bytes = n;
 118
 119     /* payload_words is what we will tell the profiler we had to allocate */
 120     payload_words = ROUNDUP_BYTES_TO_WDS(bytes);
 121
 122     /* When we actually allocate memory, we need to allow space for the
 123        header: */
 124     bytes = bytes + SIZEOF_StgArrWords;
 125     /* And we want to align to <alignment> bytes, so we need to allow space
 126        to shift up to <alignment - 1> bytes: */
 127     bytes = bytes + alignment - 1;
 128     /* Now we convert to a number of words: */
 129     words = ROUNDUP_BYTES_TO_WDS(bytes);
 130
 131     ("ptr" p) = foreign "C" allocatePinned(MyCapability() "ptr", words) [];
 132     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
 133
 134     /* Now we need to move p forward so that the payload is aligned
 135        to <alignment> bytes. Note that we are assuming that
 136        <alignment> is a power of 2, which is technically not guaranteed */
 137     p = p + ((-p - SIZEOF_StgArrWords) & (alignment - 1));
 138
 139     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 140     StgArrWords_bytes(p) = n;
 141     RET_P(p);
 142 }
 143
 144 stg_newArrayzh
 145 {
 146     W_ words, n, init, arr, p, size;
 147     /* Args: R1 = words, R2 = initialisation value */
 148
 149     n = R1;
 150     MAYBE_GC(R2_PTR,stg_newArrayzh);
 151
 152     // the mark area contains one byte for each 2^MUT_ARR_PTRS_CARD_BITS words
 153     // in the array, making sure we round up, and then rounding up to a whole
 154     // number of words.
 155     size = n + mutArrPtrsCardWords(n);
 156     words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;
 157     ("ptr" arr) = foreign "C" allocate(MyCapability() "ptr",words) [R2];
 158     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
 159
 160     SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
 161     StgMutArrPtrs_ptrs(arr) = n;
 162     StgMutArrPtrs_size(arr) = size;
 163
 164     // Initialise all elements of the the array with the value in R2
 165     init = R2;
 166     p = arr + SIZEOF_StgMutArrPtrs;
 167   for:
 168     if (p < arr + WDS(words)) {
 169         W_[p] = init;
 170         p = p + WDS(1);
 171         goto for;
 172     }
 173     // Initialise the mark bits with 0
 174   for2:
 175     if (p < arr + WDS(size)) {
 176         W_[p] = 0;
 177         p = p + WDS(1);
 178         goto for2;
 179     }
 180
 181     RET_P(arr);
 182 }
 183
 184 stg_unsafeThawArrayzh
 185 {
 186   // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
 187   //
 188   // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
 189   // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
 190   // it on the mutable list for the GC to remove (removing something from
 191   // the mutable list is not easy).
 192   //
 193   // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
 194   // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
 195   // to indicate that it is still on the mutable list.
 196   //
 197   // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
 198   // either it is on a mut_list, or it isn't.  We adopt the convention that
 199   // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
 200   // and MUT_ARR_PTRS_FROZEN otherwise.  In fact it wouldn't matter if
 201   // we put it on the mutable list more than once, but it would get scavenged
 202   // multiple times during GC, which would be unnecessarily slow.
 203   //
 204   if (StgHeader_info(R1) != stg_MUT_ARR_PTRS_FROZEN0_info) {
 205         SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
 206         recordMutable(R1, R1);
 207         // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
 208         RET_P(R1);
 209   } else {
 210         SET_INFO(R1,stg_MUT_ARR_PTRS_DIRTY_info);
 211         RET_P(R1);
 212   }
 213 }
 214
 215
 216 /* -----------------------------------------------------------------------------
 217    MutVar primitives
 218    -------------------------------------------------------------------------- */
 219
 220 stg_newMutVarzh
 221 {
 222     W_ mv;
 223     /* Args: R1 = initialisation value */
 224
 225     ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, stg_newMutVarzh);
 226
 227     mv = Hp - SIZEOF_StgMutVar + WDS(1);
 228     SET_HDR(mv,stg_MUT_VAR_DIRTY_info,W_[CCCS]);
 229     StgMutVar_var(mv) = R1;
 230
 231     RET_P(mv);
 232 }
 233
 234 stg_casMutVarzh
 235  /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */
 236 {
 237     W_ mv, old, new, h;
 238
 239     mv  = R1;
 240     old = R2;
 241     new = R3;
 242
 243     (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var,
 244                           old, new) [];
 245     if (h != old) {
 246         RET_NP(1,h);
 247     } else {
 248         RET_NP(0,h);
 249     }
 250 }
 251
 252
 253 stg_atomicModifyMutVarzh
 254 {
 255     W_ mv, f, z, x, y, r, h;
 256     /* Args: R1 :: MutVar#,  R2 :: a -> (a,b) */
 257
 258     /* If x is the current contents of the MutVar#, then
 259        We want to make the new contents point to
 260
 261          (sel_0 (f x))
 262
 263        and the return value is
 264
 265          (sel_1 (f x))
 266
 267         obviously we can share (f x).
 268
 269          z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
 270          y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
 271          r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
 272     */
 273
 274 #if MIN_UPD_SIZE > 1
 275 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
 276 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
 277 #else
 278 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
 279 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
 280 #endif
 281
 282 #if MIN_UPD_SIZE > 2
 283 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
 284 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
 285 #else
 286 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
 287 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
 288 #endif
 289
 290 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
 291
 292    HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, stg_atomicModifyMutVarzh);
 293
 294    mv = R1;
 295    f = R2;
 296
 297    TICK_ALLOC_THUNK_2();
 298    CCCS_ALLOC(THUNK_2_SIZE);
 299    z = Hp - THUNK_2_SIZE + WDS(1);
 300    SET_HDR(z, stg_ap_2_upd_info, W_[CCCS]);
 301    LDV_RECORD_CREATE(z);
 302    StgThunk_payload(z,0) = f;
 303
 304    TICK_ALLOC_THUNK_1();
 305    CCCS_ALLOC(THUNK_1_SIZE);
 306    y = z - THUNK_1_SIZE;
 307    SET_HDR(y, stg_sel_0_upd_info, W_[CCCS]);
 308    LDV_RECORD_CREATE(y);
 309    StgThunk_payload(y,0) = z;
 310
 311    TICK_ALLOC_THUNK_1();
 312    CCCS_ALLOC(THUNK_1_SIZE);
 313    r = y - THUNK_1_SIZE;
 314    SET_HDR(r, stg_sel_1_upd_info, W_[CCCS]);
 315    LDV_RECORD_CREATE(r);
 316    StgThunk_payload(r,0) = z;
 317
 318  retry:
 319    x = StgMutVar_var(mv);
 320    StgThunk_payload(z,1) = x;
 321 #ifdef THREADED_RTS
 322    (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, x, y) [];
 323    if (h != x) { goto retry; }
 324 #else
 325    StgMutVar_var(mv) = y;
 326 #endif
 327
 328    if (GET_INFO(mv) == stg_MUT_VAR_CLEAN_info) {
 329      foreign "C" dirty_MUT_VAR(BaseReg "ptr", mv "ptr") [];
 330    }
 331
 332    RET_P(r);
 333 }
 334
 335 /* -----------------------------------------------------------------------------
 336    Weak Pointer Primitives
 337    -------------------------------------------------------------------------- */
 338
 339 STRING(stg_weak_msg,"New weak pointer at %p\n")
 340
 341 stg_mkWeakzh
 342 {
 343   /* R1 = key
 344      R2 = value
 345      R3 = finalizer (or NULL)
 346   */
 347   W_ w;
 348
 349   if (R3 == NULL) {
 350     R3 = stg_NO_FINALIZER_closure;
 351   }
 352
 353   ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
 354
 355   w = Hp - SIZEOF_StgWeak + WDS(1);
 356   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 357
 358   // We don't care about cfinalizer here.
 359   // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or
 360   // something else?
 361
 362   StgWeak_key(w)        = R1;
 363   StgWeak_value(w)      = R2;
 364   StgWeak_finalizer(w)  = R3;
 365   StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure;
 366
 367   ACQUIRE_LOCK(sm_mutex);
 368   StgWeak_link(w)       = W_[weak_ptr_list];
 369   W_[weak_ptr_list]     = w;
 370   RELEASE_LOCK(sm_mutex);
 371
 372   IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
 373
 374   RET_P(w);
 375 }
 376
 377 stg_mkWeakForeignEnvzh
 378 {
 379   /* R1 = key
 380      R2 = value
 381      R3 = finalizer
 382      R4 = pointer
 383      R5 = has environment (0 or 1)
 384      R6 = environment
 385   */
 386   W_ w, payload_words, words, p;
 387
 388   W_ key, val, fptr, ptr, flag, eptr;
 389
 390   key  = R1;
 391   val  = R2;
 392   fptr = R3;
 393   ptr  = R4;
 394   flag = R5;
 395   eptr = R6;
 396
 397   ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR, stg_mkWeakForeignEnvzh );
 398
 399   w = Hp - SIZEOF_StgWeak + WDS(1);
 400   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 401
 402   payload_words = 4;
 403   words         = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
 404   ("ptr" p)     = foreign "C" allocate(MyCapability() "ptr", words) [];
 405
 406   TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
 407   SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 408
 409   StgArrWords_bytes(p)     = WDS(payload_words);
 410   StgArrWords_payload(p,0) = fptr;
 411   StgArrWords_payload(p,1) = ptr;
 412   StgArrWords_payload(p,2) = eptr;
 413   StgArrWords_payload(p,3) = flag;
 414
 415   // We don't care about the value here.
 416   // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else?
 417
 418   StgWeak_key(w)        = key;
 419   StgWeak_value(w)      = val;
 420   StgWeak_finalizer(w)  = stg_NO_FINALIZER_closure;
 421   StgWeak_cfinalizer(w) = p;
 422
 423   ACQUIRE_LOCK(sm_mutex);
 424   StgWeak_link(w)   = W_[weak_ptr_list];
 425   W_[weak_ptr_list] = w;
 426   RELEASE_LOCK(sm_mutex);
 427
 428   IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
 429
 430   RET_P(w);
 431 }
 432
 433 stg_finalizzeWeakzh
 434 {
 435   /* R1 = weak ptr
 436    */
 437   W_ w, f, arr;
 438
 439   w = R1;
 440
 441   // already dead?
 442   if (GET_INFO(w) == stg_DEAD_WEAK_info) {
 443       RET_NP(0,stg_NO_FINALIZER_closure);
 444   }
 445
 446   // kill it
 447 #ifdef PROFILING
 448   // @LDV profiling
 449   // A weak pointer is inherently used, so we do not need to call
 450   // LDV_recordDead_FILL_SLOP_DYNAMIC():
 451   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
 452   // or, LDV_recordDead():
 453   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
 454   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
 455   // large as weak pointers, so there is no need to fill the slop, either.
 456   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
 457 #endif
 458
 459   //
 460   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
 461   //
 462   SET_INFO(w,stg_DEAD_WEAK_info);
 463   LDV_RECORD_CREATE(w);
 464
 465   f   = StgWeak_finalizer(w);
 466   arr = StgWeak_cfinalizer(w);
 467
 468   StgDeadWeak_link(w) = StgWeak_link(w);
 469
 470   if (arr != stg_NO_FINALIZER_closure) {
 471     foreign "C" runCFinalizer(StgArrWords_payload(arr,0),
 472                               StgArrWords_payload(arr,1),
 473                               StgArrWords_payload(arr,2),
 474                               StgArrWords_payload(arr,3)) [];
 475   }
 476
 477   /* return the finalizer */
 478   if (f == stg_NO_FINALIZER_closure) {
 479       RET_NP(0,stg_NO_FINALIZER_closure);
 480   } else {
 481       RET_NP(1,f);
 482   }
 483 }
 484
 485 stg_deRefWeakzh
 486 {
 487   /* R1 = weak ptr */
 488   W_ w, code, val;
 489
 490   w = R1;
 491   if (GET_INFO(w) == stg_WEAK_info) {
 492     code = 1;
 493     val = StgWeak_value(w);
 494   } else {
 495     code = 0;
 496     val = w;
 497   }
 498   RET_NP(code,val);
 499 }
 500
 501 /* -----------------------------------------------------------------------------
 502    Floating point operations.
 503    -------------------------------------------------------------------------- */
 504
 505 stg_decodeFloatzuIntzh
 506 {
 507     W_ p;
 508     F_ arg;
 509     W_ mp_tmp1;
 510     W_ mp_tmp_w;
 511
 512     STK_CHK_GEN( WDS(2), NO_PTRS, stg_decodeFloatzuIntzh );
 513
 514     mp_tmp1  = Sp - WDS(1);
 515     mp_tmp_w = Sp - WDS(2);
 516
 517     /* arguments: F1 = Float# */
 518     arg = F1;
 519
 520     /* Perform the operation */
 521     foreign "C" __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg) [];
 522
 523     /* returns: (Int# (mantissa), Int# (exponent)) */
 524     RET_NN(W_[mp_tmp1], W_[mp_tmp_w]);
 525 }
 526
 527 stg_decodeDoublezu2Intzh
 528 {
 529     D_ arg;
 530     W_ p;
 531     W_ mp_tmp1;
 532     W_ mp_tmp2;
 533     W_ mp_result1;
 534     W_ mp_result2;
 535
 536     STK_CHK_GEN( WDS(4), NO_PTRS, stg_decodeDoublezu2Intzh );
 537
 538     mp_tmp1    = Sp - WDS(1);
 539     mp_tmp2    = Sp - WDS(2);
 540     mp_result1 = Sp - WDS(3);
 541     mp_result2 = Sp - WDS(4);
 542
 543     /* arguments: D1 = Double# */
 544     arg = D1;
 545
 546     /* Perform the operation */
 547     foreign "C" __decodeDouble_2Int(mp_tmp1 "ptr", mp_tmp2 "ptr",
 548                                     mp_result1 "ptr", mp_result2 "ptr",
 549                                     arg) [];
 550
 551     /* returns:
 552        (Int# (mant sign), Word# (mant high), Word# (mant low), Int# (expn)) */
 553     RET_NNNN(W_[mp_tmp1], W_[mp_tmp2], W_[mp_result1], W_[mp_result2]);
 554 }
 555
 556 /* -----------------------------------------------------------------------------
 557  * Concurrency primitives
 558  * -------------------------------------------------------------------------- */
 559
 560 stg_forkzh
 561 {
 562   /* args: R1 = closure to spark */
 563
 564   MAYBE_GC(R1_PTR, stg_forkzh);
 565
 566   W_ closure;
 567   W_ threadid;
 568   closure = R1;
 569
 570   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr",
 571                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
 572                                 closure "ptr") [];
 573
 574   /* start blocked if the current thread is blocked */
 575   StgTSO_flags(threadid) = %lobits16(
 576      TO_W_(StgTSO_flags(threadid)) |
 577      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
 578
 579   foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
 580
 581   // context switch soon, but not immediately: we don't want every
 582   // forkIO to force a context-switch.
 583   Capability_context_switch(MyCapability()) = 1 :: CInt;
 584
 585   RET_P(threadid);
 586 }
 587
 588 stg_forkOnzh
 589 {
 590   /* args: R1 = cpu, R2 = closure to spark */
 591
 592   MAYBE_GC(R2_PTR, stg_forkOnzh);
 593
 594   W_ cpu;
 595   W_ closure;
 596   W_ threadid;
 597   cpu = R1;
 598   closure = R2;
 599
 600   ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr",
 601                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
 602                                 closure "ptr") [];
 603
 604   /* start blocked if the current thread is blocked */
 605   StgTSO_flags(threadid) = %lobits16(
 606      TO_W_(StgTSO_flags(threadid)) |
 607      TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE));
 608
 609   foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
 610
 611   // context switch soon, but not immediately: we don't want every
 612   // forkIO to force a context-switch.
 613   Capability_context_switch(MyCapability()) = 1 :: CInt;
 614
 615   RET_P(threadid);
 616 }
 617
 618 stg_yieldzh
 619 {
 620   jump stg_yield_noregs;
 621 }
 622
 623 stg_myThreadIdzh
 624 {
 625   /* no args. */
 626   RET_P(CurrentTSO);
 627 }
 628
 629 stg_labelThreadzh
 630 {
 631   /* args:
 632         R1 = ThreadId#
 633         R2 = Addr# */
 634 #ifdef DEBUG
 635   foreign "C" labelThread(R1 "ptr", R2 "ptr") [];
 636 #endif
 637   jump %ENTRY_CODE(Sp(0));
 638 }
 639
 640 stg_isCurrentThreadBoundzh
 641 {
 642   /* no args */
 643   W_ r;
 644   (r) = foreign "C" isThreadBound(CurrentTSO) [];
 645   RET_N(r);
 646 }
 647
 648 stg_threadStatuszh
 649 {
 650     /* args: R1 :: ThreadId# */
 651     W_ tso;
 652     W_ why_blocked;
 653     W_ what_next;
 654     W_ ret, cap, locked;
 655
 656     tso = R1;
 657
 658     what_next   = TO_W_(StgTSO_what_next(tso));
 659     why_blocked = TO_W_(StgTSO_why_blocked(tso));
 660     // Note: these two reads are not atomic, so they might end up
 661     // being inconsistent.  It doesn't matter, since we
 662     // only return one or the other.  If we wanted to return the
 663     // contents of block_info too, then we'd have to do some synchronisation.
 664
 665     if (what_next == ThreadComplete) {
 666         ret = 16;  // NB. magic, matches up with GHC.Conc.threadStatus
 667     } else {
 668         if (what_next == ThreadKilled) {
 669             ret = 17;
 670         } else {
 671             ret = why_blocked;
 672         }
 673     }
 674
 675     cap = TO_W_(Capability_no(StgTSO_cap(tso)));
 676
 677     if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) {
 678         locked = 1;
 679     } else {
 680         locked = 0;
 681     }
 682
 683     RET_NNN(ret,cap,locked);
 684 }
 685
 686 /* -----------------------------------------------------------------------------
 687  * TVar primitives
 688  * -------------------------------------------------------------------------- */
 689
 690 #define SP_OFF 0
 691
 692 // Catch retry frame ------------------------------------------------------------
 693
 694 INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
 695 #if defined(PROFILING)
 696   W_ unused1, W_ unused2,
 697 #endif
 698   W_ unused3, P_ unused4, P_ unused5)
 699 {
 700    W_ r, frame, trec, outer;
 701
 702    frame = Sp;
 703    trec = StgTSO_trec(CurrentTSO);
 704    outer  = StgTRecHeader_enclosing_trec(trec);
 705    (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
 706    if (r != 0) {
 707      /* Succeeded (either first branch or second branch) */
 708      StgTSO_trec(CurrentTSO) = outer;
 709      Sp = Sp + SIZEOF_StgCatchRetryFrame;
 710      jump %ENTRY_CODE(Sp(SP_OFF));
 711    } else {
 712      /* Did not commit: re-execute */
 713      W_ new_trec;
 714      ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
 715      StgTSO_trec(CurrentTSO) = new_trec;
 716      if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
 717        R1 = StgCatchRetryFrame_alt_code(frame);
 718      } else {
 719        R1 = StgCatchRetryFrame_first_code(frame);
 720      }
 721      jump stg_ap_v_fast;
 722    }
 723 }
 724
 725
 726 // Atomically frame ------------------------------------------------------------
 727
 728 INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
 729 #if defined(PROFILING)
 730   W_ unused1, W_ unused2,
 731 #endif
 732   P_ code, P_ next_invariant_to_check, P_ result)
 733 {
 734   W_ frame, trec, valid, next_invariant, q, outer;
 735
 736   frame  = Sp;
 737   trec   = StgTSO_trec(CurrentTSO);
 738   result = R1;
 739   outer  = StgTRecHeader_enclosing_trec(trec);
 740
 741   if (outer == NO_TREC) {
 742     /* First time back at the atomically frame -- pick up invariants */
 743     ("ptr" q) = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") [];
 744     StgAtomicallyFrame_next_invariant_to_check(frame) = q;
 745     StgAtomicallyFrame_result(frame) = result;
 746
 747   } else {
 748     /* Second/subsequent time back at the atomically frame -- abort the
 749      * tx that's checking the invariant and move on to the next one */
 750     StgTSO_trec(CurrentTSO) = outer;
 751     q = StgAtomicallyFrame_next_invariant_to_check(frame);
 752     StgInvariantCheckQueue_my_execution(q) = trec;
 753     foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
 754     /* Don't free trec -- it's linked from q and will be stashed in the
 755      * invariant if we eventually commit. */
 756     q = StgInvariantCheckQueue_next_queue_entry(q);
 757     StgAtomicallyFrame_next_invariant_to_check(frame) = q;
 758     trec = outer;
 759   }
 760
 761   q = StgAtomicallyFrame_next_invariant_to_check(frame);
 762
 763   if (q != END_INVARIANT_CHECK_QUEUE) {
 764     /* We can't commit yet: another invariant to check */
 765     ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
 766     StgTSO_trec(CurrentTSO) = trec;
 767
 768     next_invariant = StgInvariantCheckQueue_invariant(q);
 769     R1 = StgAtomicInvariant_code(next_invariant);
 770     jump stg_ap_v_fast;
 771
 772   } else {
 773
 774     /* We've got no more invariants to check, try to commit */
 775     (valid) = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") [];
 776     if (valid != 0) {
 777       /* Transaction was valid: commit succeeded */
 778       StgTSO_trec(CurrentTSO) = NO_TREC;
 779       R1 = StgAtomicallyFrame_result(frame);
 780       Sp = Sp + SIZEOF_StgAtomicallyFrame;
 781       jump %ENTRY_CODE(Sp(SP_OFF));
 782     } else {
 783       /* Transaction was not valid: try again */
 784       ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
 785       StgTSO_trec(CurrentTSO) = trec;
 786       StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
 787       R1 = StgAtomicallyFrame_code(frame);
 788       jump stg_ap_v_fast;
 789     }
 790   }
 791 }
 792
 793 INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
 794 #if defined(PROFILING)
 795   W_ unused1, W_ unused2,
 796 #endif
 797   P_ code, P_ next_invariant_to_check, P_ result)
 798 {
 799   W_ frame, trec, valid;
 800
 801   frame = Sp;
 802
 803   /* The TSO is currently waiting: should we stop waiting? */
 804   (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
 805   if (valid != 0) {
 806     /* Previous attempt is still valid: no point trying again yet */
 807     jump stg_block_noregs;
 808   } else {
 809     /* Previous attempt is no longer valid: try again */
 810     ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
 811     StgTSO_trec(CurrentTSO) = trec;
 812     StgHeader_info(frame) = stg_atomically_frame_info;
 813     R1 = StgAtomicallyFrame_code(frame);
 814     jump stg_ap_v_fast;
 815   }
 816 }
 817
 818 // STM catch frame --------------------------------------------------------------
 819
 820 #define SP_OFF 0
 821
 822 /* Catch frames are very similar to update frames, but when entering
 823  * one we just pop the frame off the stack and perform the correct
 824  * kind of return to the activation record underneath us on the stack.
 825  */
 826
 827 INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
 828 #if defined(PROFILING)
 829   W_ unused1, W_ unused2,
 830 #endif
 831   P_ unused3, P_ unused4)
 832    {
 833       W_ r, frame, trec, outer;
 834       frame = Sp;
 835       trec = StgTSO_trec(CurrentTSO);
 836       outer  = StgTRecHeader_enclosing_trec(trec);
 837       (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
 838       if (r != 0) {
 839         /* Commit succeeded */
 840         StgTSO_trec(CurrentTSO) = outer;
 841         Sp = Sp + SIZEOF_StgCatchSTMFrame;
 842         jump Sp(SP_OFF);
 843       } else {
 844         /* Commit failed */
 845         W_ new_trec;
 846         ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
 847         StgTSO_trec(CurrentTSO) = new_trec;
 848         R1 = StgCatchSTMFrame_code(frame);
 849         jump stg_ap_v_fast;
 850       }
 851    }
 852
 853
 854 // Primop definition ------------------------------------------------------------
 855
 856 stg_atomicallyzh
 857 {
 858   W_ frame;
 859   W_ old_trec;
 860   W_ new_trec;
 861
 862   // stmStartTransaction may allocate
 863   MAYBE_GC (R1_PTR, stg_atomicallyzh);
 864
 865   /* Args: R1 = m :: STM a */
 866   STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, stg_atomicallyzh);
 867
 868   old_trec = StgTSO_trec(CurrentTSO);
 869
 870   /* Nested transactions are not allowed; raise an exception */
 871   if (old_trec != NO_TREC) {
 872      R1 = base_ControlziExceptionziBase_nestedAtomically_closure;
 873      jump stg_raisezh;
 874   }
 875
 876   /* Set up the atomically frame */
 877   Sp = Sp - SIZEOF_StgAtomicallyFrame;
 878   frame = Sp;
 879
 880   SET_HDR(frame,stg_atomically_frame_info, W_[CCCS]);
 881   StgAtomicallyFrame_code(frame) = R1;
 882   StgAtomicallyFrame_result(frame) = NO_TREC;
 883   StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
 884
 885   /* Start the memory transcation */
 886   ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1];
 887   StgTSO_trec(CurrentTSO) = new_trec;
 888
 889   /* Apply R1 to the realworld token */
 890   jump stg_ap_v_fast;
 891 }
 892
 893
 894 stg_catchSTMzh
 895 {
 896   W_ frame;
 897
 898   /* Args: R1 :: STM a */
 899   /* Args: R2 :: Exception -> STM a */
 900   STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, stg_catchSTMzh);
 901
 902   /* Set up the catch frame */
 903   Sp = Sp - SIZEOF_StgCatchSTMFrame;
 904   frame = Sp;
 905
 906   SET_HDR(frame, stg_catch_stm_frame_info, W_[CCCS]);
 907   StgCatchSTMFrame_handler(frame) = R2;
 908   StgCatchSTMFrame_code(frame) = R1;
 909
 910   /* Start a nested transaction to run the body of the try block in */
 911   W_ cur_trec;
 912   W_ new_trec;
 913   cur_trec = StgTSO_trec(CurrentTSO);
 914   ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
 915   StgTSO_trec(CurrentTSO) = new_trec;
 916
 917   /* Apply R1 to the realworld token */
 918   jump stg_ap_v_fast;
 919 }
 920
 921
 922 stg_catchRetryzh
 923 {
 924   W_ frame;
 925   W_ new_trec;
 926   W_ trec;
 927
 928   // stmStartTransaction may allocate
 929   MAYBE_GC (R1_PTR & R2_PTR, stg_catchRetryzh);
 930
 931   /* Args: R1 :: STM a */
 932   /* Args: R2 :: STM a */
 933   STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, stg_catchRetryzh);
 934
 935   /* Start a nested transaction within which to run the first code */
 936   trec = StgTSO_trec(CurrentTSO);
 937   ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2];
 938   StgTSO_trec(CurrentTSO) = new_trec;
 939
 940   /* Set up the catch-retry frame */
 941   Sp = Sp - SIZEOF_StgCatchRetryFrame;
 942   frame = Sp;
 943
 944   SET_HDR(frame, stg_catch_retry_frame_info, W_[CCCS]);
 945   StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
 946   StgCatchRetryFrame_first_code(frame) = R1;
 947   StgCatchRetryFrame_alt_code(frame) = R2;
 948
 949   /* Apply R1 to the realworld token */
 950   jump stg_ap_v_fast;
 951 }
 952
 953
 954 stg_retryzh
 955 {
 956   W_ frame_type;
 957   W_ frame;
 958   W_ trec;
 959   W_ outer;
 960   W_ r;
 961
 962   MAYBE_GC (NO_PTRS, stg_retryzh); // STM operations may allocate
 963
 964   // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
 965 retry_pop_stack:
 966   SAVE_THREAD_STATE();
 967   (frame_type) = foreign "C" findRetryFrameHelper(MyCapability(), CurrentTSO "ptr") [];
 968   LOAD_THREAD_STATE();
 969   frame = Sp;
 970   trec = StgTSO_trec(CurrentTSO);
 971   outer  = StgTRecHeader_enclosing_trec(trec);
 972
 973   if (frame_type == CATCH_RETRY_FRAME) {
 974     // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
 975     ASSERT(outer != NO_TREC);
 976     // Abort the transaction attempting the current branch
 977     foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
 978     foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
 979     if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
 980       // Retry in the first branch: try the alternative
 981       ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
 982       StgTSO_trec(CurrentTSO) = trec;
 983       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
 984       R1 = StgCatchRetryFrame_alt_code(frame);
 985       jump stg_ap_v_fast;
 986     } else {
 987       // Retry in the alternative code: propagate the retry
 988       StgTSO_trec(CurrentTSO) = outer;
 989       Sp = Sp + SIZEOF_StgCatchRetryFrame;
 990       goto retry_pop_stack;
 991     }
 992   }
 993
 994   // We've reached the ATOMICALLY_FRAME: attempt to wait
 995   ASSERT(frame_type == ATOMICALLY_FRAME);
 996   if (outer != NO_TREC) {
 997     // We called retry while checking invariants, so abort the current
 998     // invariant check (merging its TVar accesses into the parents read
 999     // set so we'll wait on them)
1000     foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
1001     foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
1002     trec = outer;
1003     StgTSO_trec(CurrentTSO) = trec;
1004     outer  = StgTRecHeader_enclosing_trec(trec);
1005   }
1006   ASSERT(outer == NO_TREC);
1007
1008   (r) = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") [];
1009   if (r != 0) {
1010     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1011     StgHeader_info(frame) = stg_atomically_waiting_frame_info;
1012     Sp = frame;
1013     // Fix up the stack in the unregisterised case: the return convention is different.
1014     R3 = trec; // passing to stmWaitUnblock()
1015     jump stg_block_stmwait;
1016   } else {
1017     // Transaction was not valid: retry immediately
1018     ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
1019     StgTSO_trec(CurrentTSO) = trec;
1020     R1 = StgAtomicallyFrame_code(frame);
1021     Sp = frame;
1022     jump stg_ap_v_fast;
1023   }
1024 }
1025
1026
1027 stg_checkzh
1028 {
1029   W_ trec, closure;
1030
1031   /* Args: R1 = invariant closure */
1032   MAYBE_GC (R1_PTR, stg_checkzh);
1033
1034   trec = StgTSO_trec(CurrentTSO);
1035   closure = R1;
1036   foreign "C" stmAddInvariantToCheck(MyCapability() "ptr",
1037                                      trec "ptr",
1038                                      closure "ptr") [];
1039
1040   jump %ENTRY_CODE(Sp(0));
1041 }
1042
1043
1044 stg_newTVarzh
1045 {
1046   W_ tv;
1047   W_ new_value;
1048
1049   /* Args: R1 = initialisation value */
1050
1051   MAYBE_GC (R1_PTR, stg_newTVarzh);
1052   new_value = R1;
1053   ("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
1054   RET_P(tv);
1055 }
1056
1057
1058 stg_readTVarzh
1059 {
1060   W_ trec;
1061   W_ tvar;
1062   W_ result;
1063
1064   /* Args: R1 = TVar closure */
1065
1066   MAYBE_GC (R1_PTR, stg_readTVarzh); // Call to stmReadTVar may allocate
1067   trec = StgTSO_trec(CurrentTSO);
1068   tvar = R1;
1069   ("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
1070
1071   RET_P(result);
1072 }
1073
1074 stg_readTVarIOzh
1075 {
1076     W_ result;
1077
1078 again:
1079     result = StgTVar_current_value(R1);
1080     if (%INFO_PTR(result) == stg_TREC_HEADER_info) {
1081         goto again;
1082     }
1083     RET_P(result);
1084 }
1085
1086 stg_writeTVarzh
1087 {
1088   W_ trec;
1089   W_ tvar;
1090   W_ new_value;
1091
1092   /* Args: R1 = TVar closure */
1093   /*       R2 = New value    */
1094
1095   MAYBE_GC (R1_PTR & R2_PTR, stg_writeTVarzh); // Call to stmWriteTVar may allocate
1096   trec = StgTSO_trec(CurrentTSO);
1097   tvar = R1;
1098   new_value = R2;
1099   foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
1100
1101   jump %ENTRY_CODE(Sp(0));
1102 }
1103
1104
1105 /* -----------------------------------------------------------------------------
1106  * MVar primitives
1107  *
1108  * take & putMVar work as follows.  Firstly, an important invariant:
1109  *
1110  *    If the MVar is full, then the blocking queue contains only
1111  *    threads blocked on putMVar, and if the MVar is empty then the
1112  *    blocking queue contains only threads blocked on takeMVar.
1113  *
1114  * takeMvar:
1115  *    MVar empty : then add ourselves to the blocking queue
1116  *    MVar full  : remove the value from the MVar, and
1117  *                 blocking queue empty     : return
1118  *                 blocking queue non-empty : perform the first blocked putMVar
1119  *                                            from the queue, and wake up the
1120  *                                            thread (MVar is now full again)
1121  *
1122  * putMVar is just the dual of the above algorithm.
1123  *
1124  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1125  * the stack of the thread waiting to do the putMVar.  See
1126  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1127  * the stack layout, and the PerformPut and PerformTake macros below.
1128  *
1129  * It is important that a blocked take or put is woken up with the
1130  * take/put already performed, because otherwise there would be a
1131  * small window of vulnerability where the thread could receive an
1132  * exception and never perform its take or put, and we'd end up with a
1133  * deadlock.
1134  *
1135  * -------------------------------------------------------------------------- */
1136
1137 stg_isEmptyMVarzh
1138 {
1139     /* args: R1 = MVar closure */
1140
1141     if (StgMVar_value(R1) == stg_END_TSO_QUEUE_closure) {
1142         RET_N(1);
1143     } else {
1144         RET_N(0);
1145     }
1146 }
1147
1148 stg_newMVarzh
1149 {
1150     /* args: none */
1151     W_ mvar;
1152
1153     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, stg_newMVarzh );
1154
1155     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1156     SET_HDR(mvar,stg_MVAR_DIRTY_info,W_[CCCS]);
1157         // MVARs start dirty: generation 0 has no mutable list
1158     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1159     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1160     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1161     RET_P(mvar);
1162 }
1163
1164
1165 #define PerformTake(stack, value)               \
1166     W_ sp;                                      \
1167     sp = StgStack_sp(stack);                    \
1168     W_[sp + WDS(1)] = value;                    \
1169     W_[sp + WDS(0)] = stg_gc_unpt_r1_info;
1170
1171 #define PerformPut(stack,lval)                  \
1172     W_ sp;                                      \
1173     sp = StgStack_sp(stack) + WDS(3);           \
1174     StgStack_sp(stack) = sp;                    \
1175     lval = W_[sp - WDS(1)];
1176
1177 stg_takeMVarzh
1178 {
1179     W_ mvar, val, info, tso, q;
1180
1181     /* args: R1 = MVar closure */
1182     mvar = R1;
1183
1184 #if defined(THREADED_RTS)
1185     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1186 #else
1187     info = GET_INFO(mvar);
1188 #endif
1189
1190     if (info == stg_MVAR_CLEAN_info) {
1191         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
1192     }
1193
1194     /* If the MVar is empty, put ourselves on its blocking queue,
1195      * and wait until we're woken up.
1196      */
1197     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1198
1199         // Note [mvar-heap-check] We want to do the heap check in the
1200         // branch here, to avoid the conditional in the common case.
1201         // However, we've already locked the MVar above, so we better
1202         // be careful to unlock it again if the the heap check fails.
1203         // Unfortunately we don't have an easy way to inject any code
1204         // into the heap check generated by the code generator, so we
1205         // have to do it in stg_gc_gen (see HeapStackCheck.cmm).
1206         HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR, stg_takeMVarzh);
1207
1208         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1209
1210         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1211         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1212         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1213
1214         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1215             StgMVar_head(mvar) = q;
1216         } else {
1217             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1218             foreign "C" recordClosureMutated(MyCapability() "ptr",
1219                                              StgMVar_tail(mvar)) [];
1220         }
1221         StgTSO__link(CurrentTSO)       = q;
1222         StgTSO_block_info(CurrentTSO)  = mvar;
1223         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1224         StgMVar_tail(mvar)             = q;
1225
1226         R1 = mvar;
1227         jump stg_block_takemvar;
1228     }
1229
1230     /* we got the value... */
1231     val = StgMVar_value(mvar);
1232
1233     q = StgMVar_head(mvar);
1234 loop:
1235     if (q == stg_END_TSO_QUEUE_closure) {
1236         /* No further putMVars, MVar is now empty */
1237         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1238         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1239         RET_P(val);
1240     }
1241     if (StgHeader_info(q) == stg_IND_info ||
1242         StgHeader_info(q) == stg_MSG_NULL_info) {
1243         q = StgInd_indirectee(q);
1244         goto loop;
1245     }
1246
1247     // There are putMVar(s) waiting... wake up the first thread on the queue
1248
1249     tso = StgMVarTSOQueue_tso(q);
1250     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1251     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1252         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1253     }
1254
1255     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1256     ASSERT(StgTSO_block_info(tso) == mvar);
1257
1258     // actually perform the putMVar for the thread that we just woke up
1259     W_ stack;
1260     stack = StgTSO_stackobj(tso);
1261     PerformPut(stack, StgMVar_value(mvar));
1262
1263     // indicate that the MVar operation has now completed.
1264     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1265
1266     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1267
1268     foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
1269
1270     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1271     RET_P(val);
1272 }
1273
1274
1275 stg_tryTakeMVarzh
1276 {
1277     W_ mvar, val, info, tso, q;
1278
1279     /* args: R1 = MVar closure */
1280     mvar = R1;
1281
1282 #if defined(THREADED_RTS)
1283     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1284 #else
1285     info = GET_INFO(mvar);
1286 #endif
1287
1288     /* If the MVar is empty, put ourselves on its blocking queue,
1289      * and wait until we're woken up.
1290      */
1291     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1292 #if defined(THREADED_RTS)
1293         unlockClosure(mvar, info);
1294 #endif
1295         /* HACK: we need a pointer to pass back,
1296          * so we abuse NO_FINALIZER_closure
1297          */
1298         RET_NP(0, stg_NO_FINALIZER_closure);
1299     }
1300
1301     if (info == stg_MVAR_CLEAN_info) {
1302         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr") [];
1303     }
1304
1305     /* we got the value... */
1306     val = StgMVar_value(mvar);
1307
1308     q = StgMVar_head(mvar);
1309 loop:
1310     if (q == stg_END_TSO_QUEUE_closure) {
1311         /* No further putMVars, MVar is now empty */
1312         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1313         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1314         RET_NP(1, val);
1315     }
1316     if (StgHeader_info(q) == stg_IND_info ||
1317         StgHeader_info(q) == stg_MSG_NULL_info) {
1318         q = StgInd_indirectee(q);
1319         goto loop;
1320     }
1321
1322     // There are putMVar(s) waiting... wake up the first thread on the queue
1323
1324     tso = StgMVarTSOQueue_tso(q);
1325     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1326     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1327         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1328     }
1329
1330     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1331     ASSERT(StgTSO_block_info(tso) == mvar);
1332
1333     // actually perform the putMVar for the thread that we just woke up
1334     W_ stack;
1335     stack = StgTSO_stackobj(tso);
1336     PerformPut(stack, StgMVar_value(mvar));
1337
1338     // indicate that the MVar operation has now completed.
1339     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1340
1341     // no need to mark the TSO dirty, we have only written END_TSO_QUEUE.
1342
1343     foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
1344
1345     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1346     RET_NP(1,val);
1347 }
1348
1349
1350 stg_putMVarzh
1351 {
1352     W_ mvar, val, info, tso, q;
1353
1354     /* args: R1 = MVar, R2 = value */
1355     mvar = R1;
1356     val  = R2;
1357
1358 #if defined(THREADED_RTS)
1359     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1360 #else
1361     info = GET_INFO(mvar);
1362 #endif
1363
1364     if (info == stg_MVAR_CLEAN_info) {
1365         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
1366     }
1367
1368     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1369
1370         // see Note [mvar-heap-check] above
1371         HP_CHK_GEN_TICKY(SIZEOF_StgMVarTSOQueue, R1_PTR & R2_PTR, stg_putMVarzh);
1372
1373         q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1);
1374
1375         SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM);
1376         StgMVarTSOQueue_link(q) = END_TSO_QUEUE;
1377         StgMVarTSOQueue_tso(q)  = CurrentTSO;
1378
1379         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1380             StgMVar_head(mvar) = q;
1381         } else {
1382             StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q;
1383             foreign "C" recordClosureMutated(MyCapability() "ptr",
1384                                              StgMVar_tail(mvar)) [];
1385         }
1386         StgTSO__link(CurrentTSO)       = q;
1387         StgTSO_block_info(CurrentTSO)  = mvar;
1388         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1389         StgMVar_tail(mvar)             = q;
1390
1391         R1 = mvar;
1392         R2 = val;
1393         jump stg_block_putmvar;
1394     }
1395
1396     q = StgMVar_head(mvar);
1397 loop:
1398     if (q == stg_END_TSO_QUEUE_closure) {
1399         /* No further takes, the MVar is now full. */
1400         StgMVar_value(mvar) = val;
1401         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1402         jump %ENTRY_CODE(Sp(0));
1403     }
1404     if (StgHeader_info(q) == stg_IND_info ||
1405         StgHeader_info(q) == stg_MSG_NULL_info) {
1406         q = StgInd_indirectee(q);
1407         goto loop;
1408     }
1409
1410     // There are takeMVar(s) waiting: wake up the first one
1411
1412     tso = StgMVarTSOQueue_tso(q);
1413     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1414     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1415         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1416     }
1417
1418     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1419     ASSERT(StgTSO_block_info(tso) == mvar);
1420
1421     // actually perform the takeMVar
1422     W_ stack;
1423     stack = StgTSO_stackobj(tso);
1424     PerformTake(stack, val);
1425
1426     // indicate that the MVar operation has now completed.
1427     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1428
1429     if (TO_W_(StgStack_dirty(stack)) == 0) {
1430         foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
1431     }
1432
1433     foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
1434
1435     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1436     jump %ENTRY_CODE(Sp(0));
1437 }
1438
1439
1440 stg_tryPutMVarzh
1441 {
1442     W_ mvar, val, info, tso, q;
1443
1444     /* args: R1 = MVar, R2 = value */
1445     mvar = R1;
1446     val  = R2;
1447
1448 #if defined(THREADED_RTS)
1449     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1450 #else
1451     info = GET_INFO(mvar);
1452 #endif
1453
1454     if (info == stg_MVAR_CLEAN_info) {
1455         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
1456     }
1457
1458     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1459 #if defined(THREADED_RTS)
1460         unlockClosure(mvar, info);
1461 #endif
1462         RET_N(0);
1463     }
1464
1465     q = StgMVar_head(mvar);
1466 loop:
1467     if (q == stg_END_TSO_QUEUE_closure) {
1468         /* No further takes, the MVar is now full. */
1469         StgMVar_value(mvar) = val;
1470         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1471         RET_N(1);
1472     }
1473     if (StgHeader_info(q) == stg_IND_info ||
1474         StgHeader_info(q) == stg_MSG_NULL_info) {
1475         q = StgInd_indirectee(q);
1476         goto loop;
1477     }
1478
1479     // There are takeMVar(s) waiting: wake up the first one
1480
1481     tso = StgMVarTSOQueue_tso(q);
1482     StgMVar_head(mvar) = StgMVarTSOQueue_link(q);
1483     if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1484         StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1485     }
1486
1487     ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16);
1488     ASSERT(StgTSO_block_info(tso) == mvar);
1489
1490     // actually perform the takeMVar
1491     W_ stack;
1492     stack = StgTSO_stackobj(tso);
1493     PerformTake(stack, val);
1494
1495     // indicate that the MVar operation has now completed.
1496     StgTSO__link(tso) = stg_END_TSO_QUEUE_closure;
1497
1498     if (TO_W_(StgStack_dirty(stack)) == 0) {
1499         foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") [];
1500     }
1501
1502     foreign "C" tryWakeupThread(MyCapability() "ptr", tso) [];
1503
1504     unlockClosure(mvar, stg_MVAR_DIRTY_info);
1505     RET_N(1);
1506 }
1507
1508
1509 /* -----------------------------------------------------------------------------
1510    Stable pointer primitives
1511    -------------------------------------------------------------------------  */
1512
1513 stg_makeStableNamezh
1514 {
1515     W_ index, sn_obj;
1516
1517     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, stg_makeStableNamezh );
1518
1519     (index) = foreign "C" lookupStableName(R1 "ptr") [];
1520
1521     /* Is there already a StableName for this heap object?
1522      *  stable_ptr_table is a pointer to an array of snEntry structs.
1523      */
1524     if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
1525         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1526         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1527         StgStableName_sn(sn_obj) = index;
1528         snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
1529     } else {
1530         sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
1531     }
1532
1533     RET_P(sn_obj);
1534 }
1535
1536
1537 stg_makeStablePtrzh
1538 {
1539     /* Args: R1 = a */
1540     W_ sp;
1541     MAYBE_GC(R1_PTR, stg_makeStablePtrzh);
1542     ("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") [];
1543     RET_N(sp);
1544 }
1545
1546 stg_deRefStablePtrzh
1547 {
1548     /* Args: R1 = the stable ptr */
1549     W_ r, sp;
1550     sp = R1;
1551     r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
1552     RET_P(r);
1553 }
1554
1555 /* -----------------------------------------------------------------------------
1556    Bytecode object primitives
1557    -------------------------------------------------------------------------  */
1558
1559 stg_newBCOzh
1560 {
1561     /* R1 = instrs
1562        R2 = literals
1563        R3 = ptrs
1564        R4 = arity
1565        R5 = bitmap array
1566     */
1567     W_ bco, bitmap_arr, bytes, words;
1568
1569     bitmap_arr = R5;
1570
1571     words = BYTES_TO_WDS(SIZEOF_StgBCO) + BYTE_ARR_WDS(bitmap_arr);
1572     bytes = WDS(words);
1573
1574     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, stg_newBCOzh );
1575
1576     bco = Hp - bytes + WDS(1);
1577     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1578
1579     StgBCO_instrs(bco)     = R1;
1580     StgBCO_literals(bco)   = R2;
1581     StgBCO_ptrs(bco)       = R3;
1582     StgBCO_arity(bco)      = HALF_W_(R4);
1583     StgBCO_size(bco)       = HALF_W_(words);
1584
1585     // Copy the arity/bitmap info into the BCO
1586     W_ i;
1587     i = 0;
1588 for:
1589     if (i < BYTE_ARR_WDS(bitmap_arr)) {
1590         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1591         i = i + 1;
1592         goto for;
1593     }
1594
1595     RET_P(bco);
1596 }
1597
1598
1599 stg_mkApUpd0zh
1600 {
1601     // R1 = the BCO# for the AP
1602     //
1603     W_ ap;
1604
1605     // This function is *only* used to wrap zero-arity BCOs in an
1606     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1607     // saturated and always points directly to a FUN or BCO.
1608     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1609            StgBCO_arity(R1) == HALF_W_(0));
1610
1611     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, stg_mkApUpd0zh);
1612     TICK_ALLOC_UP_THK(0, 0);
1613     CCCS_ALLOC(SIZEOF_StgAP);
1614
1615     ap = Hp - SIZEOF_StgAP + WDS(1);
1616     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1617
1618     StgAP_n_args(ap) = HALF_W_(0);
1619     StgAP_fun(ap) = R1;
1620
1621     RET_P(ap);
1622 }
1623
1624 stg_unpackClosurezh
1625 {
1626 /* args: R1 = closure to analyze */
1627 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
1628
1629     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
1630     info  = %GET_STD_INFO(UNTAG(R1));
1631
1632     // Some closures have non-standard layout, so we omit those here.
1633     W_ type;
1634     type = TO_W_(%INFO_TYPE(info));
1635     switch [0 .. N_CLOSURE_TYPES] type {
1636     case THUNK_SELECTOR : {
1637         ptrs = 1;
1638         nptrs = 0;
1639         goto out;
1640     }
1641     case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
1642          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
1643         ptrs = 0;
1644         nptrs = 0;
1645         goto out;
1646     }
1647     default: {
1648         ptrs  = TO_W_(%INFO_PTRS(info));
1649         nptrs = TO_W_(%INFO_NPTRS(info));
1650         goto out;
1651     }}
1652 out:
1653
1654     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
1655     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
1656     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
1657     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
1658
1659     ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, stg_unpackClosurezh);
1660
1661     W_ clos;
1662     clos = UNTAG(R1);
1663
1664     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
1665     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
1666
1667     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
1668     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
1669     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
1670
1671     p = 0;
1672 for:
1673     if(p < ptrs) {
1674          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
1675          p = p + 1;
1676          goto for;
1677     }
1678     /* We can leave the card table uninitialised, since the array is
1679        allocated in the nursery.  The GC will fill it in if/when the array
1680        is promoted. */
1681
1682     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
1683     StgArrWords_bytes(nptrs_arr) = WDS(nptrs);
1684     p = 0;
1685 for2:
1686     if(p < nptrs) {
1687          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
1688          p = p + 1;
1689          goto for2;
1690     }
1691     RET_NPP(info, ptrs_arr, nptrs_arr);
1692 }
1693
1694 /* -----------------------------------------------------------------------------
1695    Thread I/O blocking primitives
1696    -------------------------------------------------------------------------- */
1697
1698 /* Add a thread to the end of the blocked queue. (C-- version of the C
1699  * macro in Schedule.h).
1700  */
1701 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1702     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
1703     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1704       W_[blocked_queue_hd] = tso;                       \
1705     } else {                                            \
1706       foreign "C" setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso) []; \
1707     }                                                   \
1708     W_[blocked_queue_tl] = tso;
1709
1710 stg_waitReadzh
1711 {
1712     /* args: R1 */
1713 #ifdef THREADED_RTS
1714     foreign "C" barf("waitRead# on threaded RTS") never returns;
1715 #else
1716
1717     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1718     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1719     StgTSO_block_info(CurrentTSO) = R1;
1720     // No locking - we're not going to use this interface in the
1721     // threaded RTS anyway.
1722     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1723     jump stg_block_noregs;
1724 #endif
1725 }
1726
1727 stg_waitWritezh
1728 {
1729     /* args: R1 */
1730 #ifdef THREADED_RTS
1731     foreign "C" barf("waitWrite# on threaded RTS") never returns;
1732 #else
1733
1734     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1735     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1736     StgTSO_block_info(CurrentTSO) = R1;
1737     // No locking - we're not going to use this interface in the
1738     // threaded RTS anyway.
1739     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1740     jump stg_block_noregs;
1741 #endif
1742 }
1743
1744
1745 STRING(stg_delayzh_malloc_str, "stg_delayzh")
1746 stg_delayzh
1747 {
1748 #ifdef mingw32_HOST_OS
1749     W_ ares;
1750     CInt reqID;
1751 #else
1752     W_ t, prev, target;
1753 #endif
1754
1755 #ifdef THREADED_RTS
1756     foreign "C" barf("delay# on threaded RTS") never returns;
1757 #else
1758
1759     /* args: R1 (microsecond delay amount) */
1760     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1761     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1762
1763 #ifdef mingw32_HOST_OS
1764
1765     /* could probably allocate this on the heap instead */
1766     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1767                                             stg_delayzh_malloc_str);
1768     (reqID) = foreign "C" addDelayRequest(R1);
1769     StgAsyncIOResult_reqID(ares)   = reqID;
1770     StgAsyncIOResult_len(ares)     = 0;
1771     StgAsyncIOResult_errCode(ares) = 0;
1772     StgTSO_block_info(CurrentTSO)  = ares;
1773
1774     /* Having all async-blocked threads reside on the blocked_queue
1775      * simplifies matters, so change the status to OnDoProc put the
1776      * delayed thread on the blocked_queue.
1777      */
1778     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1779     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1780     jump stg_block_async_void;
1781
1782 #else
1783
1784     W_ time;
1785     W_ divisor;
1786     (time) = foreign "C" getourtimeofday() [R1];
1787     divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags));
1788     if (divisor == 0) {
1789         divisor = 50;
1790     }
1791     divisor = divisor * 1000;
1792     target = ((R1 + divisor - 1) / divisor) /* divide rounding up */
1793            + time + 1; /* Add 1 as getourtimeofday rounds down */
1794     StgTSO_block_info(CurrentTSO) = target;
1795
1796     /* Insert the new thread in the sleeping queue. */
1797     prev = NULL;
1798     t = W_[sleeping_queue];
1799 while:
1800     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1801         prev = t;
1802         t = StgTSO__link(t);
1803         goto while;
1804     }
1805
1806     StgTSO__link(CurrentTSO) = t;
1807     if (prev == NULL) {
1808         W_[sleeping_queue] = CurrentTSO;
1809     } else {
1810         foreign "C" setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO) [];
1811     }
1812     jump stg_block_noregs;
1813 #endif
1814 #endif /* !THREADED_RTS */
1815 }
1816
1817
1818 #ifdef mingw32_HOST_OS
1819 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
1820 stg_asyncReadzh
1821 {
1822     W_ ares;
1823     CInt reqID;
1824
1825 #ifdef THREADED_RTS
1826     foreign "C" barf("asyncRead# on threaded RTS") never returns;
1827 #else
1828
1829     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1830     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1831     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1832
1833     /* could probably allocate this on the heap instead */
1834     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1835                                             stg_asyncReadzh_malloc_str)
1836                         [R1,R2,R3,R4];
1837     (reqID) = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr") [];
1838     StgAsyncIOResult_reqID(ares)   = reqID;
1839     StgAsyncIOResult_len(ares)     = 0;
1840     StgAsyncIOResult_errCode(ares) = 0;
1841     StgTSO_block_info(CurrentTSO)  = ares;
1842     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1843     jump stg_block_async;
1844 #endif
1845 }
1846
1847 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
1848 stg_asyncWritezh
1849 {
1850     W_ ares;
1851     CInt reqID;
1852
1853 #ifdef THREADED_RTS
1854     foreign "C" barf("asyncWrite# on threaded RTS") never returns;
1855 #else
1856
1857     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1858     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1859     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1860
1861     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1862                                             stg_asyncWritezh_malloc_str)
1863                         [R1,R2,R3,R4];
1864     (reqID) = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr") [];
1865
1866     StgAsyncIOResult_reqID(ares)   = reqID;
1867     StgAsyncIOResult_len(ares)     = 0;
1868     StgAsyncIOResult_errCode(ares) = 0;
1869     StgTSO_block_info(CurrentTSO)  = ares;
1870     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1871     jump stg_block_async;
1872 #endif
1873 }
1874
1875 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
1876 stg_asyncDoProczh
1877 {
1878     W_ ares;
1879     CInt reqID;
1880
1881 #ifdef THREADED_RTS
1882     foreign "C" barf("asyncDoProc# on threaded RTS") never returns;
1883 #else
1884
1885     /* args: R1 = proc, R2 = param */
1886     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1887     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1888
1889     /* could probably allocate this on the heap instead */
1890     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1891                                             stg_asyncDoProczh_malloc_str)
1892                                 [R1,R2];
1893     (reqID) = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr") [];
1894     StgAsyncIOResult_reqID(ares)   = reqID;
1895     StgAsyncIOResult_len(ares)     = 0;
1896     StgAsyncIOResult_errCode(ares) = 0;
1897     StgTSO_block_info(CurrentTSO) = ares;
1898     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1899     jump stg_block_async;
1900 #endif
1901 }
1902 #endif
1903
1904 /* -----------------------------------------------------------------------------
1905  * noDuplicate#
1906  *
1907  * noDuplicate# tries to ensure that none of the thunks under
1908  * evaluation by the current thread are also under evaluation by
1909  * another thread.  It relies on *both* threads doing noDuplicate#;
1910  * the second one will get blocked if they are duplicating some work.
1911  *
1912  * The idea is that noDuplicate# is used within unsafePerformIO to
1913  * ensure that the IO operation is performed at most once.
1914  * noDuplicate# calls threadPaused which acquires an exclusive lock on
1915  * all the thunks currently under evaluation by the current thread.
1916  *
1917  * Consider the following scenario.  There is a thunk A, whose
1918  * evaluation requires evaluating thunk B, where thunk B is an
1919  * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
1920  * is pre-empted before it enters B, and claims A by blackholing it
1921  * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
1922  *
1923  *      thread 1                      thread 2
1924  *   +-----------+                 +---------------+
1925  *   |    -------+-----> A <-------+-------        |
1926  *   |  update   |   BLACKHOLE     | marked_update |
1927  *   +-----------+                 +---------------+
1928  *   |           |                 |               |
1929  *        ...                             ...
1930  *   |           |                 +---------------+
1931  *   +-----------+
1932  *   |     ------+-----> B
1933  *   |  update   |   BLACKHOLE
1934  *   +-----------+
1935  *
1936  * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
1937  * calls threadPaused, which walks up the stack and
1938  *  - claims B on behalf of thread 1
1939  *  - then it reaches the update frame for A, which it sees is already
1940  *    a BLACKHOLE and is therefore owned by another thread.  Since
1941  *    thread 1 is duplicating work, the computation up to the update
1942  *    frame for A is suspended, including thunk B.
1943  *  - thunk B, which is an unsafePerformIO, has now been reverted to
1944  *    an AP_STACK which could be duplicated - BAD!
1945  *  - The solution is as follows: before calling threadPaused, we
1946  *    leave a frame on the stack (stg_noDuplicate_info) that will call
1947  *    noDuplicate# again if the current computation is suspended and
1948  *    restarted.
1949  *
1950  * See the test program in concurrent/prog003 for a way to demonstrate
1951  * this.  It needs to be run with +RTS -N3 or greater, and the bug
1952  * only manifests occasionally (once very 10 runs or so).
1953  * -------------------------------------------------------------------------- */
1954
1955 INFO_TABLE_RET(stg_noDuplicate, RET_SMALL)
1956 {
1957     Sp_adj(1);
1958     jump stg_noDuplicatezh;
1959 }
1960
1961 stg_noDuplicatezh
1962 {
1963     STK_CHK_GEN( WDS(1), NO_PTRS, stg_noDuplicatezh );
1964     // leave noDuplicate frame in case the current
1965     // computation is suspended and restarted (see above).
1966     Sp_adj(-1);
1967     Sp(0) = stg_noDuplicate_info;
1968
1969     SAVE_THREAD_STATE();
1970     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1971     foreign "C" threadPaused (MyCapability() "ptr", CurrentTSO "ptr") [];
1972
1973     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
1974         jump stg_threadFinished;
1975     } else {
1976         LOAD_THREAD_STATE();
1977         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1978         // remove the stg_noDuplicate frame if it is still there.
1979         if (Sp(0) == stg_noDuplicate_info) {
1980             Sp_adj(1);
1981         }
1982         jump %ENTRY_CODE(Sp(0));
1983     }
1984 }
1985
1986 /* -----------------------------------------------------------------------------
1987    Misc. primitives
1988    -------------------------------------------------------------------------- */
1989
1990 stg_getApStackValzh
1991 {
1992    W_ ap_stack, offset, val, ok;
1993
1994    /* args: R1 = AP_STACK, R2 = offset */
1995    ap_stack = R1;
1996    offset   = R2;
1997
1998    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
1999         ok = 1;
2000         val = StgAP_STACK_payload(ap_stack,offset);
2001    } else {
2002         ok = 0;
2003         val = R1;
2004    }
2005    RET_NP(ok,val);
2006 }
2007
2008 // Write the cost center stack of the first argument on stderr; return
2009 // the second.  Possibly only makes sense for already evaluated
2010 // things?
2011 stg_traceCcszh
2012 {
2013     W_ ccs;
2014
2015 #ifdef PROFILING
2016     ccs = StgHeader_ccs(UNTAG(R1));
2017     foreign "C" fprintCCS_stderr(ccs "ptr") [R2];
2018 #endif
2019
2020     R1 = R2;
2021     ENTER();
2022 }
2023
2024 stg_getSparkzh
2025 {
2026    W_ spark;
2027
2028 #ifndef THREADED_RTS
2029    RET_NP(0,ghczmprim_GHCziTypes_False_closure);
2030 #else
2031    (spark) = foreign "C" findSpark(MyCapability());
2032    if (spark != 0) {
2033       RET_NP(1,spark);
2034    } else {
2035       RET_NP(0,ghczmprim_GHCziTypes_False_closure);
2036    }
2037 #endif
2038 }
2039
2040 stg_numSparkszh
2041 {
2042   W_ n;
2043 #ifdef THREADED_RTS
2044   (n) = foreign "C" dequeElements(Capability_sparks(MyCapability()));
2045 #else
2046   n = 0;
2047 #endif
2048   RET_N(n);
2049 }
2050
2051 stg_traceEventzh
2052 {
2053    W_ msg;
2054    msg = R1;
2055
2056 #if defined(TRACING) || defined(DEBUG)
2057
2058    foreign "C" traceUserMsg(MyCapability() "ptr", msg "ptr") [];
2059
2060 #elif defined(DTRACE)
2061
2062    W_ enabled;
2063
2064    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
2065    // RtsProbes.h, but that header file includes unistd.h, which doesn't
2066    // work in Cmm
2067 #if !defined(solaris2_TARGET_OS)
2068    (enabled) = foreign "C" __dtrace_isenabled$HaskellEvent$user__msg$v1() [];
2069 #else
2070    // Solaris' DTrace can't handle the
2071    //     __dtrace_isenabled$HaskellEvent$user__msg$v1
2072    // call above. This call is just for testing whether the user__msg
2073    // probe is enabled, and is here for just performance optimization.
2074    // Since preparation for the probe is not that complex I disable usage of
2075    // this test above for Solaris and enable the probe usage manually
2076    // here. Please note that this does not mean that the probe will be
2077    // used during the runtime! You still need to enable it by consumption
2078    // in your dtrace script as you do with any other probe.
2079    enabled = 1;
2080 #endif
2081    if (enabled != 0) {
2082      foreign "C" dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr") [];
2083    }
2084
2085 #endif
2086    jump %ENTRY_CODE(Sp(0));
2087 }