rts/PrimOps.cmm

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