rts/PrimOps.cmm

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