rts/PrimOps.cmm

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