rts/PrimOps.cmm

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