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