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 #if defined(THREADED_RTS)
1208       unlockClosure(mvar, stg_MVAR_DIRTY_info);
1209 #else
1210       SET_INFO(mvar,stg_MVAR_DIRTY_info);
1211 #endif
1212       RET_P(val);
1213   }
1214   else
1215   {
1216       /* No further putMVars, MVar is now empty */
1217       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1218
1219 #if defined(THREADED_RTS)
1220       unlockClosure(mvar, stg_MVAR_DIRTY_info);
1221 #else
1222       SET_INFO(mvar,stg_MVAR_DIRTY_info);
1223 #endif
1224
1225       RET_P(val);
1226   }
1227 }
1228
1229
1230 stg_tryTakeMVarzh
1231 {
1232     W_ mvar, val, info, tso;
1233
1234     /* args: R1 = MVar closure */
1235
1236     mvar = R1;
1237
1238 #if defined(THREADED_RTS)
1239     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1240 #else
1241     info = GET_INFO(mvar);
1242 #endif
1243
1244     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
1245 #if defined(THREADED_RTS)
1246         unlockClosure(mvar, info);
1247 #endif
1248         /* HACK: we need a pointer to pass back,
1249          * so we abuse NO_FINALIZER_closure
1250          */
1251         RET_NP(0, stg_NO_FINALIZER_closure);
1252     }
1253
1254     if (info == stg_MVAR_CLEAN_info) {
1255         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
1256     }
1257
1258     /* we got the value... */
1259     val = StgMVar_value(mvar);
1260
1261     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1262
1263         /* There are putMVar(s) waiting...
1264          * wake up the first thread on the queue
1265          */
1266         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1267
1268         /* actually perform the putMVar for the thread that we just woke up */
1269         tso = StgMVar_head(mvar);
1270         PerformPut(tso,StgMVar_value(mvar));
1271         if (TO_W_(StgTSO_dirty(tso)) == 0) {
1272             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
1273         }
1274
1275         ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr",
1276                                               StgMVar_head(mvar) "ptr", 1) [];
1277         StgMVar_head(mvar) = tso;
1278
1279         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1280             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1281         }
1282 #if defined(THREADED_RTS)
1283         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1284 #else
1285         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1286 #endif
1287     }
1288     else
1289     {
1290         /* No further putMVars, MVar is now empty */
1291         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1292 #if defined(THREADED_RTS)
1293         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1294 #else
1295         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1296 #endif
1297     }
1298
1299     RET_NP(1, val);
1300 }
1301
1302
1303 stg_putMVarzh
1304 {
1305     W_ mvar, val, info, tso;
1306
1307     /* args: R1 = MVar, R2 = value */
1308     mvar = R1;
1309     val  = R2;
1310
1311 #if defined(THREADED_RTS)
1312     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
1313 #else
1314     info = GET_INFO(mvar);
1315 #endif
1316
1317     if (info == stg_MVAR_CLEAN_info) {
1318         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
1319     }
1320
1321     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1322         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1323             StgMVar_head(mvar) = CurrentTSO;
1324         } else {
1325             foreign "C" setTSOLink(MyCapability() "ptr",
1326                                    StgMVar_tail(mvar) "ptr",
1327                                    CurrentTSO) [];
1328         }
1329         StgTSO__link(CurrentTSO)       = stg_END_TSO_QUEUE_closure;
1330         StgTSO_block_info(CurrentTSO)  = mvar;
1331         // write barrier for throwTo(), which looks at block_info
1332         // if why_blocked==BlockedOnMVar.
1333         prim %write_barrier() [];
1334         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1335         StgMVar_tail(mvar) = CurrentTSO;
1336
1337         R1 = mvar;
1338         R2 = val;
1339         jump stg_block_putmvar;
1340     }
1341
1342     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1343
1344         /* There are takeMVar(s) waiting: wake up the first one
1345          */
1346         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1347
1348         /* actually perform the takeMVar */
1349         tso = StgMVar_head(mvar);
1350         PerformTake(tso, val);
1351         if (TO_W_(StgTSO_dirty(tso)) == 0) {
1352             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
1353         }
1354
1355         ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr",
1356                                               StgMVar_head(mvar) "ptr", 1) [];
1357         StgMVar_head(mvar) = tso;
1358
1359         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1360             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1361         }
1362
1363 #if defined(THREADED_RTS)
1364         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1365 #else
1366         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1367 #endif
1368         jump %ENTRY_CODE(Sp(0));
1369     }
1370     else
1371     {
1372         /* No further takes, the MVar is now full. */
1373         StgMVar_value(mvar) = val;
1374
1375 #if defined(THREADED_RTS)
1376         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1377 #else
1378         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1379 #endif
1380         jump %ENTRY_CODE(Sp(0));
1381     }
1382
1383     /* ToDo: yield afterward for better communication performance? */
1384 }
1385
1386
1387 stg_tryPutMVarzh
1388 {
1389     W_ mvar, info, tso;
1390
1391     /* args: R1 = MVar, R2 = value */
1392     mvar = R1;
1393
1394 #if defined(THREADED_RTS)
1395     ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2];
1396 #else
1397     info = GET_INFO(mvar);
1398 #endif
1399
1400     if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) {
1401 #if defined(THREADED_RTS)
1402         unlockClosure(mvar, info);
1403 #endif
1404         RET_N(0);
1405     }
1406
1407     if (info == stg_MVAR_CLEAN_info) {
1408         foreign "C" dirty_MVAR(BaseReg "ptr", mvar "ptr");
1409     }
1410
1411     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1412
1413         /* There are takeMVar(s) waiting: wake up the first one
1414          */
1415         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1416
1417         /* actually perform the takeMVar */
1418         tso = StgMVar_head(mvar);
1419         PerformTake(tso, R2);
1420         if (TO_W_(StgTSO_dirty(tso)) == 0) {
1421             foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") [];
1422         }
1423
1424         ("ptr" tso) = foreign "C" unblockOne_(MyCapability() "ptr",
1425                                               StgMVar_head(mvar) "ptr", 1) [];
1426         StgMVar_head(mvar) = tso;
1427
1428         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1429             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1430         }
1431
1432 #if defined(THREADED_RTS)
1433         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1434 #else
1435         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1436 #endif
1437     }
1438     else
1439     {
1440         /* No further takes, the MVar is now full. */
1441         StgMVar_value(mvar) = R2;
1442
1443 #if defined(THREADED_RTS)
1444         unlockClosure(mvar, stg_MVAR_DIRTY_info);
1445 #else
1446         SET_INFO(mvar,stg_MVAR_DIRTY_info);
1447 #endif
1448     }
1449
1450     RET_N(1);
1451     /* ToDo: yield afterward for better communication performance? */
1452 }
1453
1454
1455 /* -----------------------------------------------------------------------------
1456    Stable pointer primitives
1457    -------------------------------------------------------------------------  */
1458
1459 stg_makeStableNamezh
1460 {
1461     W_ index, sn_obj;
1462
1463     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, stg_makeStableNamezh );
1464
1465     (index) = foreign "C" lookupStableName(R1 "ptr") [];
1466
1467     /* Is there already a StableName for this heap object?
1468      *  stable_ptr_table is a pointer to an array of snEntry structs.
1469      */
1470     if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
1471         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1472         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1473         StgStableName_sn(sn_obj) = index;
1474         snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
1475     } else {
1476         sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
1477     }
1478
1479     RET_P(sn_obj);
1480 }
1481
1482
1483 stg_makeStablePtrzh
1484 {
1485     /* Args: R1 = a */
1486     W_ sp;
1487     MAYBE_GC(R1_PTR, stg_makeStablePtrzh);
1488     ("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") [];
1489     RET_N(sp);
1490 }
1491
1492 stg_deRefStablePtrzh
1493 {
1494     /* Args: R1 = the stable ptr */
1495     W_ r, sp;
1496     sp = R1;
1497     r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
1498     RET_P(r);
1499 }
1500
1501 /* -----------------------------------------------------------------------------
1502    Bytecode object primitives
1503    -------------------------------------------------------------------------  */
1504
1505 stg_newBCOzh
1506 {
1507     /* R1 = instrs
1508        R2 = literals
1509        R3 = ptrs
1510        R4 = arity
1511        R5 = bitmap array
1512     */
1513     W_ bco, bitmap_arr, bytes, words;
1514
1515     bitmap_arr = R5;
1516
1517     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1518     bytes = WDS(words);
1519
1520     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R5_PTR, stg_newBCOzh );
1521
1522     bco = Hp - bytes + WDS(1);
1523     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1524
1525     StgBCO_instrs(bco)     = R1;
1526     StgBCO_literals(bco)   = R2;
1527     StgBCO_ptrs(bco)       = R3;
1528     StgBCO_arity(bco)      = HALF_W_(R4);
1529     StgBCO_size(bco)       = HALF_W_(words);
1530
1531     // Copy the arity/bitmap info into the BCO
1532     W_ i;
1533     i = 0;
1534 for:
1535     if (i < StgArrWords_words(bitmap_arr)) {
1536         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1537         i = i + 1;
1538         goto for;
1539     }
1540
1541     RET_P(bco);
1542 }
1543
1544
1545 stg_mkApUpd0zh
1546 {
1547     // R1 = the BCO# for the AP
1548     //
1549     W_ ap;
1550
1551     // This function is *only* used to wrap zero-arity BCOs in an
1552     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1553     // saturated and always points directly to a FUN or BCO.
1554     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1555            StgBCO_arity(R1) == HALF_W_(0));
1556
1557     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, stg_mkApUpd0zh);
1558     TICK_ALLOC_UP_THK(0, 0);
1559     CCCS_ALLOC(SIZEOF_StgAP);
1560
1561     ap = Hp - SIZEOF_StgAP + WDS(1);
1562     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1563
1564     StgAP_n_args(ap) = HALF_W_(0);
1565     StgAP_fun(ap) = R1;
1566
1567     RET_P(ap);
1568 }
1569
1570 stg_unpackClosurezh
1571 {
1572 /* args: R1 = closure to analyze */
1573 // TODO: Consider the absence of ptrs or nonptrs as a special case ?
1574
1575     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
1576     info  = %GET_STD_INFO(UNTAG(R1));
1577
1578     // Some closures have non-standard layout, so we omit those here.
1579     W_ type;
1580     type = TO_W_(%INFO_TYPE(info));
1581     switch [0 .. N_CLOSURE_TYPES] type {
1582     case THUNK_SELECTOR : {
1583         ptrs = 1;
1584         nptrs = 0;
1585         goto out;
1586     }
1587     case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1,
1588          THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : {
1589         ptrs = 0;
1590         nptrs = 0;
1591         goto out;
1592     }
1593     default: {
1594         ptrs  = TO_W_(%INFO_PTRS(info));
1595         nptrs = TO_W_(%INFO_NPTRS(info));
1596         goto out;
1597     }}
1598 out:
1599
1600     W_ ptrs_arr_sz, ptrs_arr_cards, nptrs_arr_sz;
1601     nptrs_arr_sz = SIZEOF_StgArrWords   + WDS(nptrs);
1602     ptrs_arr_cards = mutArrPtrsCardWords(ptrs);
1603     ptrs_arr_sz  = SIZEOF_StgMutArrPtrs + WDS(ptrs) + WDS(ptrs_arr_cards);
1604
1605     ALLOC_PRIM (ptrs_arr_sz + nptrs_arr_sz, R1_PTR, stg_unpackClosurezh);
1606
1607     W_ clos;
1608     clos = UNTAG(R1);
1609
1610     ptrs_arr  = Hp - nptrs_arr_sz - ptrs_arr_sz + WDS(1);
1611     nptrs_arr = Hp - nptrs_arr_sz + WDS(1);
1612
1613     SET_HDR(ptrs_arr, stg_MUT_ARR_PTRS_FROZEN_info, W_[CCCS]);
1614     StgMutArrPtrs_ptrs(ptrs_arr) = ptrs;
1615     StgMutArrPtrs_size(ptrs_arr) = ptrs + ptrs_arr_cards;
1616
1617     p = 0;
1618 for:
1619     if(p < ptrs) {
1620          W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p);
1621          p = p + 1;
1622          goto for;
1623     }
1624     /* We can leave the card table uninitialised, since the array is
1625        allocated in the nursery.  The GC will fill it in if/when the array
1626        is promoted. */
1627
1628     SET_HDR(nptrs_arr, stg_ARR_WORDS_info, W_[CCCS]);
1629     StgArrWords_words(nptrs_arr) = nptrs;
1630     p = 0;
1631 for2:
1632     if(p < nptrs) {
1633          W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs);
1634          p = p + 1;
1635          goto for2;
1636     }
1637     RET_NPP(info, ptrs_arr, nptrs_arr);
1638 }
1639
1640 /* -----------------------------------------------------------------------------
1641    Thread I/O blocking primitives
1642    -------------------------------------------------------------------------- */
1643
1644 /* Add a thread to the end of the blocked queue. (C-- version of the C
1645  * macro in Schedule.h).
1646  */
1647 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1648     ASSERT(StgTSO__link(tso) == END_TSO_QUEUE);         \
1649     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1650       W_[blocked_queue_hd] = tso;                       \
1651     } else {                                            \
1652       foreign "C" setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso) []; \
1653     }                                                   \
1654     W_[blocked_queue_tl] = tso;
1655
1656 stg_waitReadzh
1657 {
1658     /* args: R1 */
1659 #ifdef THREADED_RTS
1660     foreign "C" barf("waitRead# on threaded RTS") never returns;
1661 #else
1662
1663     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1664     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1665     StgTSO_block_info(CurrentTSO) = R1;
1666     // No locking - we're not going to use this interface in the
1667     // threaded RTS anyway.
1668     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1669     jump stg_block_noregs;
1670 #endif
1671 }
1672
1673 stg_waitWritezh
1674 {
1675     /* args: R1 */
1676 #ifdef THREADED_RTS
1677     foreign "C" barf("waitWrite# on threaded RTS") never returns;
1678 #else
1679
1680     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1681     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1682     StgTSO_block_info(CurrentTSO) = R1;
1683     // No locking - we're not going to use this interface in the
1684     // threaded RTS anyway.
1685     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1686     jump stg_block_noregs;
1687 #endif
1688 }
1689
1690
1691 STRING(stg_delayzh_malloc_str, "stg_delayzh")
1692 stg_delayzh
1693 {
1694 #ifdef mingw32_HOST_OS
1695     W_ ares;
1696     CInt reqID;
1697 #else
1698     W_ t, prev, target;
1699 #endif
1700
1701 #ifdef THREADED_RTS
1702     foreign "C" barf("delay# on threaded RTS") never returns;
1703 #else
1704
1705     /* args: R1 (microsecond delay amount) */
1706     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1707     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1708
1709 #ifdef mingw32_HOST_OS
1710
1711     /* could probably allocate this on the heap instead */
1712     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1713                                             stg_delayzh_malloc_str);
1714     (reqID) = foreign "C" addDelayRequest(R1);
1715     StgAsyncIOResult_reqID(ares)   = reqID;
1716     StgAsyncIOResult_len(ares)     = 0;
1717     StgAsyncIOResult_errCode(ares) = 0;
1718     StgTSO_block_info(CurrentTSO)  = ares;
1719
1720     /* Having all async-blocked threads reside on the blocked_queue
1721      * simplifies matters, so change the status to OnDoProc put the
1722      * delayed thread on the blocked_queue.
1723      */
1724     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1725     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1726     jump stg_block_async_void;
1727
1728 #else
1729
1730     W_ time;
1731     W_ divisor;
1732     (time) = foreign "C" getourtimeofday() [R1];
1733     divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags));
1734     if (divisor == 0) {
1735         divisor = 50;
1736     }
1737     divisor = divisor * 1000;
1738     target = ((R1 + divisor - 1) / divisor) /* divide rounding up */
1739            + time + 1; /* Add 1 as getourtimeofday rounds down */
1740     StgTSO_block_info(CurrentTSO) = target;
1741
1742     /* Insert the new thread in the sleeping queue. */
1743     prev = NULL;
1744     t = W_[sleeping_queue];
1745 while:
1746     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1747         prev = t;
1748         t = StgTSO__link(t);
1749         goto while;
1750     }
1751
1752     StgTSO__link(CurrentTSO) = t;
1753     if (prev == NULL) {
1754         W_[sleeping_queue] = CurrentTSO;
1755     } else {
1756         foreign "C" setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO) [];
1757     }
1758     jump stg_block_noregs;
1759 #endif
1760 #endif /* !THREADED_RTS */
1761 }
1762
1763
1764 #ifdef mingw32_HOST_OS
1765 STRING(stg_asyncReadzh_malloc_str, "stg_asyncReadzh")
1766 stg_asyncReadzh
1767 {
1768     W_ ares;
1769     CInt reqID;
1770
1771 #ifdef THREADED_RTS
1772     foreign "C" barf("asyncRead# on threaded RTS") never returns;
1773 #else
1774
1775     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1776     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1777     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1778
1779     /* could probably allocate this on the heap instead */
1780     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1781                                             stg_asyncReadzh_malloc_str)
1782                         [R1,R2,R3,R4];
1783     (reqID) = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr") [];
1784     StgAsyncIOResult_reqID(ares)   = reqID;
1785     StgAsyncIOResult_len(ares)     = 0;
1786     StgAsyncIOResult_errCode(ares) = 0;
1787     StgTSO_block_info(CurrentTSO)  = ares;
1788     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1789     jump stg_block_async;
1790 #endif
1791 }
1792
1793 STRING(stg_asyncWritezh_malloc_str, "stg_asyncWritezh")
1794 stg_asyncWritezh
1795 {
1796     W_ ares;
1797     CInt reqID;
1798
1799 #ifdef THREADED_RTS
1800     foreign "C" barf("asyncWrite# on threaded RTS") never returns;
1801 #else
1802
1803     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1804     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1805     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1806
1807     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1808                                             stg_asyncWritezh_malloc_str)
1809                         [R1,R2,R3,R4];
1810     (reqID) = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr") [];
1811
1812     StgAsyncIOResult_reqID(ares)   = reqID;
1813     StgAsyncIOResult_len(ares)     = 0;
1814     StgAsyncIOResult_errCode(ares) = 0;
1815     StgTSO_block_info(CurrentTSO)  = ares;
1816     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1817     jump stg_block_async;
1818 #endif
1819 }
1820
1821 STRING(stg_asyncDoProczh_malloc_str, "stg_asyncDoProczh")
1822 stg_asyncDoProczh
1823 {
1824     W_ ares;
1825     CInt reqID;
1826
1827 #ifdef THREADED_RTS
1828     foreign "C" barf("asyncDoProc# on threaded RTS") never returns;
1829 #else
1830
1831     /* args: R1 = proc, R2 = param */
1832     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1833     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1834
1835     /* could probably allocate this on the heap instead */
1836     ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1837                                             stg_asyncDoProczh_malloc_str)
1838                                 [R1,R2];
1839     (reqID) = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr") [];
1840     StgAsyncIOResult_reqID(ares)   = reqID;
1841     StgAsyncIOResult_len(ares)     = 0;
1842     StgAsyncIOResult_errCode(ares) = 0;
1843     StgTSO_block_info(CurrentTSO) = ares;
1844     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1845     jump stg_block_async;
1846 #endif
1847 }
1848 #endif
1849
1850 /* -----------------------------------------------------------------------------
1851  * noDuplicate#
1852  *
1853  * noDuplicate# tries to ensure that none of the thunks under
1854  * evaluation by the current thread are also under evaluation by
1855  * another thread.  It relies on *both* threads doing noDuplicate#;
1856  * the second one will get blocked if they are duplicating some work.
1857  *
1858  * The idea is that noDuplicate# is used within unsafePerformIO to
1859  * ensure that the IO operation is performed at most once.
1860  * noDuplicate# calls threadPaused which acquires an exclusive lock on
1861  * all the thunks currently under evaluation by the current thread.
1862  *
1863  * Consider the following scenario.  There is a thunk A, whose
1864  * evaluation requires evaluating thunk B, where thunk B is an
1865  * unsafePerformIO.  Two threads, 1 and 2, bother enter A.  Thread 2
1866  * is pre-empted before it enters B, and claims A by blackholing it
1867  * (in threadPaused).  Thread 1 now enters B, and calls noDuplicate#.
1868  *
1869  *      thread 1                      thread 2
1870  *   +-----------+                 +---------------+
1871  *   |    -------+-----> A <-------+-------        |
1872  *   |  update   |   BLACKHOLE     | marked_update |
1873  *   +-----------+                 +---------------+
1874  *   |           |                 |               |
1875  *        ...                             ...
1876  *   |           |                 +---------------+
1877  *   +-----------+
1878  *   |     ------+-----> B
1879  *   |  update   |   BLACKHOLE
1880  *   +-----------+
1881  *
1882  * At this point: A is a blackhole, owned by thread 2.  noDuplicate#
1883  * calls threadPaused, which walks up the stack and
1884  *  - claims B on behalf of thread 1
1885  *  - then it reaches the update frame for A, which it sees is already
1886  *    a BLACKHOLE and is therefore owned by another thread.  Since
1887  *    thread 1 is duplicating work, the computation up to the update
1888  *    frame for A is suspended, including thunk B.
1889  *  - thunk B, which is an unsafePerformIO, has now been reverted to
1890  *    an AP_STACK which could be duplicated - BAD!
1891  *  - The solution is as follows: before calling threadPaused, we
1892  *    leave a frame on the stack (stg_noDuplicate_info) that will call
1893  *    noDuplicate# again if the current computation is suspended and
1894  *    restarted.
1895  *
1896  * See the test program in concurrent/prog003 for a way to demonstrate
1897  * this.  It needs to be run with +RTS -N3 or greater, and the bug
1898  * only manifests occasionally (once very 10 runs or so).
1899  * -------------------------------------------------------------------------- */
1900
1901 INFO_TABLE_RET(stg_noDuplicate, RET_SMALL)
1902 {
1903     Sp_adj(1);
1904     jump stg_noDuplicatezh;
1905 }
1906
1907 stg_noDuplicatezh
1908 {
1909     STK_CHK_GEN( WDS(1), NO_PTRS, stg_noDuplicatezh );
1910     // leave noDuplicate frame in case the current
1911     // computation is suspended and restarted (see above).
1912     Sp_adj(-1);
1913     Sp(0) = stg_noDuplicate_info;
1914
1915     SAVE_THREAD_STATE();
1916     ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1917     foreign "C" threadPaused (MyCapability() "ptr", CurrentTSO "ptr") [];
1918
1919     if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
1920         jump stg_threadFinished;
1921     } else {
1922         LOAD_THREAD_STATE();
1923         ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
1924         // remove the stg_noDuplicate frame if it is still there.
1925         if (Sp(0) == stg_noDuplicate_info) {
1926             Sp_adj(1);
1927         }
1928         jump %ENTRY_CODE(Sp(0));
1929     }
1930 }
1931
1932 /* -----------------------------------------------------------------------------
1933    Misc. primitives
1934    -------------------------------------------------------------------------- */
1935
1936 stg_getApStackValzh
1937 {
1938    W_ ap_stack, offset, val, ok;
1939
1940    /* args: R1 = AP_STACK, R2 = offset */
1941    ap_stack = R1;
1942    offset   = R2;
1943
1944    if (%INFO_PTR(ap_stack) == stg_AP_STACK_info) {
1945         ok = 1;
1946         val = StgAP_STACK_payload(ap_stack,offset);
1947    } else {
1948         ok = 0;
1949         val = R1;
1950    }
1951    RET_NP(ok,val);
1952 }
1953
1954 // Write the cost center stack of the first argument on stderr; return
1955 // the second.  Possibly only makes sense for already evaluated
1956 // things?
1957 stg_traceCcszh
1958 {
1959     W_ ccs;
1960
1961 #ifdef PROFILING
1962     ccs = StgHeader_ccs(UNTAG(R1));
1963     foreign "C" fprintCCS_stderr(ccs "ptr") [R2];
1964 #endif
1965
1966     R1 = R2;
1967     ENTER();
1968 }
1969
1970 stg_getSparkzh
1971 {
1972    W_ spark;
1973
1974 #ifndef THREADED_RTS
1975    RET_NP(0,ghczmprim_GHCziBool_False_closure);
1976 #else
1977    (spark) = foreign "C" findSpark(MyCapability());
1978    if (spark != 0) {
1979       RET_NP(1,spark);
1980    } else {
1981       RET_NP(0,ghczmprim_GHCziBool_False_closure);
1982    }
1983 #endif
1984 }
1985
1986 stg_traceEventzh
1987 {
1988    W_ msg;
1989    msg = R1;
1990
1991 #if defined(TRACING) || defined(DEBUG)
1992
1993    foreign "C" traceUserMsg(MyCapability() "ptr", msg "ptr") [];
1994
1995 #elif defined(DTRACE)
1996
1997    W_ enabled;
1998
1999    // We should go through the macro HASKELLEVENT_USER_MSG_ENABLED from
2000    // RtsProbes.h, but that header file includes unistd.h, which doesn't
2001    // work in Cmm
2002    (enabled) = foreign "C" __dtrace_isenabled$HaskellEvent$user__msg$v1() [];
2003    if (enabled != 0) {
2004      foreign "C" dtraceUserMsgWrapper(MyCapability() "ptr", msg "ptr") [];
2005    }
2006
2007 #endif
2008    jump %ENTRY_CODE(Sp(0));
2009 }