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