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