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