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