ghc/rts/PrimOps.cmm

   1 /* -----------------------------------------------------------------------------
   2  *
   3  * (c) The GHC Team, 1998-2004
   4  *
   5  * Out-of-line primitive operations
   6  *
   7  * This file contains the implementations of all the primitive
   8  * operations ("primops") which are not expanded inline.  See
   9  * ghc/compiler/prelude/primops.txt.pp for a list of all the primops;
  10  * this file contains code for most of those with the attribute
  11  * out_of_line=True.
  12  *
  13  * Entry convention: the entry convention for a primop is that all the
  14  * args are in Stg registers (R1, R2, etc.).  This is to make writing
  15  * the primops easier.  (see compiler/codeGen/CgCallConv.hs).
  16  *
  17  * Return convention: results from a primop are generally returned
  18  * using the ordinary unboxed tuple return convention.  The C-- parser
  19  * implements the RET_xxxx() macros to perform unboxed-tuple returns
  20  * based on the prevailing return convention.
  21  *
  22  * This file is written in a subset of C--, extended with various
  23  * features specific to GHC.  It is compiled by GHC directly.  For the
  24  * syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
  25  *
  26  * ---------------------------------------------------------------------------*/
  27
  28 #include "Cmm.h"
  29
  30 /*-----------------------------------------------------------------------------
  31   Array Primitives
  32
  33   Basically just new*Array - the others are all inline macros.
  34
  35   The size arg is always passed in R1, and the result returned in R1.
  36
  37   The slow entry point is for returning from a heap check, the saved
  38   size argument must be re-loaded from the stack.
  39   -------------------------------------------------------------------------- */
  40
  41 /* for objects that are *less* than the size of a word, make sure we
  42  * round up to the nearest word for the size of the array.
  43  */
  44
  45 newByteArrayzh_fast
  46 {
  47     W_ words, payload_words, n, p;
  48     MAYBE_GC(NO_PTRS,newByteArrayzh_fast);
  49     n = R1;
  50     payload_words = ROUNDUP_BYTES_TO_WDS(n);
  51     words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
  52     "ptr" p = foreign "C" allocateLocal(MyCapability() "ptr",words) [];
  53     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
  54     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
  55     StgArrWords_words(p) = payload_words;
  56     RET_P(p);
  57 }
  58
  59 newPinnedByteArrayzh_fast
  60 {
  61     W_ words, payload_words, n, p;
  62
  63     MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);
  64     n = R1;
  65     payload_words = ROUNDUP_BYTES_TO_WDS(n);
  66
  67     // We want an 8-byte aligned array.  allocatePinned() gives us
  68     // 8-byte aligned memory by default, but we want to align the
  69     // *goods* inside the ArrWords object, so we have to check the
  70     // size of the ArrWords header and adjust our size accordingly.
  71     words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
  72     if ((SIZEOF_StgArrWords & 7) != 0) {
  73         words = words + 1;
  74     }
  75
  76     "ptr" p = foreign "C" allocatePinned(words) [];
  77     TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
  78
  79     // Again, if the ArrWords header isn't a multiple of 8 bytes, we
  80     // have to push the object forward one word so that the goods
  81     // fall on an 8-byte boundary.
  82     if ((SIZEOF_StgArrWords & 7) != 0) {
  83         p = p + WDS(1);
  84     }
  85
  86     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
  87     StgArrWords_words(p) = payload_words;
  88     RET_P(p);
  89 }
  90
  91 newArrayzh_fast
  92 {
  93     W_ words, n, init, arr, p;
  94     /* Args: R1 = words, R2 = initialisation value */
  95
  96     n = R1;
  97     MAYBE_GC(R2_PTR,newArrayzh_fast);
  98
  99     words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n;
 100     "ptr" arr = foreign "C" allocateLocal(MyCapability() "ptr",words) [];
 101     TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
 102
 103     SET_HDR(arr, stg_MUT_ARR_PTRS_info, W_[CCCS]);
 104     StgMutArrPtrs_ptrs(arr) = n;
 105
 106     // Initialise all elements of the the array with the value in R2
 107     init = R2;
 108     p = arr + SIZEOF_StgMutArrPtrs;
 109   for:
 110     if (p < arr + WDS(words)) {
 111         W_[p] = init;
 112         p = p + WDS(1);
 113         goto for;
 114     }
 115
 116     RET_P(arr);
 117 }
 118
 119 unsafeThawArrayzh_fast
 120 {
 121   // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
 122   //
 123   // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
 124   // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
 125   // it on the mutable list for the GC to remove (removing something from
 126   // the mutable list is not easy, because the mut_list is only singly-linked).
 127   //
 128   // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list,
 129   // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0
 130   // to indicate that it is still on the mutable list.
 131   //
 132   // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
 133   // either it is on a mut_list, or it isn't.  We adopt the convention that
 134   // the closure type is MUT_ARR_PTRS_FROZEN0 if it is on the mutable list,
 135   // and MUT_ARR_PTRS_FROZEN otherwise.  In fact it wouldn't matter if
 136   // we put it on the mutable list more than once, but it would get scavenged
 137   // multiple times during GC, which would be unnecessarily slow.
 138   //
 139   if (StgHeader_info(R1) != stg_MUT_ARR_PTRS_FROZEN0_info) {
 140         SET_INFO(R1,stg_MUT_ARR_PTRS_info);
 141         foreign "C" recordMutableLock(R1 "ptr") [R1];
 142         // must be done after SET_INFO, because it ASSERTs closure_MUTABLE()
 143         RET_P(R1);
 144   } else {
 145         SET_INFO(R1,stg_MUT_ARR_PTRS_info);
 146         RET_P(R1);
 147   }
 148 }
 149
 150 /* -----------------------------------------------------------------------------
 151    MutVar primitives
 152    -------------------------------------------------------------------------- */
 153
 154 newMutVarzh_fast
 155 {
 156     W_ mv;
 157     /* Args: R1 = initialisation value */
 158
 159     ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, newMutVarzh_fast);
 160
 161     mv = Hp - SIZEOF_StgMutVar + WDS(1);
 162     SET_HDR(mv,stg_MUT_VAR_info,W_[CCCS]);
 163     StgMutVar_var(mv) = R1;
 164
 165     RET_P(mv);
 166 }
 167
 168 atomicModifyMutVarzh_fast
 169 {
 170     W_ mv, z, x, y, r;
 171     /* Args: R1 :: MutVar#,  R2 :: a -> (a,b) */
 172
 173     /* If x is the current contents of the MutVar#, then
 174        We want to make the new contents point to
 175
 176          (sel_0 (f x))
 177
 178        and the return value is
 179
 180          (sel_1 (f x))
 181
 182         obviously we can share (f x).
 183
 184          z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
 185          y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
 186          r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
 187     */
 188
 189 #if MIN_UPD_SIZE > 1
 190 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
 191 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
 192 #else
 193 #define THUNK_1_SIZE (SIZEOF_StgThunkHeader + WDS(1))
 194 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
 195 #endif
 196
 197 #if MIN_UPD_SIZE > 2
 198 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(MIN_UPD_SIZE))
 199 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
 200 #else
 201 #define THUNK_2_SIZE (SIZEOF_StgThunkHeader + WDS(2))
 202 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
 203 #endif
 204
 205 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
 206
 207    HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
 208
 209 #if defined(SMP)
 210     foreign "C" ACQUIRE_LOCK(sm_mutex "ptr");
 211 #endif
 212
 213    x = StgMutVar_var(R1);
 214
 215    TICK_ALLOC_THUNK_2();
 216    CCCS_ALLOC(THUNK_2_SIZE);
 217    z = Hp - THUNK_2_SIZE + WDS(1);
 218    SET_HDR(z, stg_ap_2_upd_info, W_[CCCS]);
 219    LDV_RECORD_CREATE(z);
 220    StgThunk_payload(z,0) = R2;
 221    StgThunk_payload(z,1) = x;
 222
 223    TICK_ALLOC_THUNK_1();
 224    CCCS_ALLOC(THUNK_1_SIZE);
 225    y = z - THUNK_1_SIZE;
 226    SET_HDR(y, stg_sel_0_upd_info, W_[CCCS]);
 227    LDV_RECORD_CREATE(y);
 228    StgThunk_payload(y,0) = z;
 229
 230    StgMutVar_var(R1) = y;
 231
 232    TICK_ALLOC_THUNK_1();
 233    CCCS_ALLOC(THUNK_1_SIZE);
 234    r = y - THUNK_1_SIZE;
 235    SET_HDR(r, stg_sel_1_upd_info, W_[CCCS]);
 236    LDV_RECORD_CREATE(r);
 237    StgThunk_payload(r,0) = z;
 238
 239 #if defined(SMP)
 240     foreign "C" RELEASE_LOCK(sm_mutex "ptr") [];
 241 #endif
 242
 243    RET_P(r);
 244 }
 245
 246 /* -----------------------------------------------------------------------------
 247    Weak Pointer Primitives
 248    -------------------------------------------------------------------------- */
 249
 250 STRING(stg_weak_msg,"New weak pointer at %p\n")
 251
 252 mkWeakzh_fast
 253 {
 254   /* R1 = key
 255      R2 = value
 256      R3 = finalizer (or NULL)
 257   */
 258   W_ w;
 259
 260   if (R3 == NULL) {
 261     R3 = stg_NO_FINALIZER_closure;
 262   }
 263
 264   ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakzh_fast );
 265
 266   w = Hp - SIZEOF_StgWeak + WDS(1);
 267   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 268
 269   StgWeak_key(w)       = R1;
 270   StgWeak_value(w)     = R2;
 271   StgWeak_finalizer(w) = R3;
 272
 273   StgWeak_link(w)       = W_[weak_ptr_list];
 274   W_[weak_ptr_list]     = w;
 275
 276   IF_DEBUG(weak, foreign "C" debugBelch(stg_weak_msg,w) []);
 277
 278   RET_P(w);
 279 }
 280
 281
 282 finalizzeWeakzh_fast
 283 {
 284   /* R1 = weak ptr
 285    */
 286   W_ w, f;
 287
 288   w = R1;
 289
 290   // already dead?
 291   if (GET_INFO(w) == stg_DEAD_WEAK_info) {
 292       RET_NP(0,stg_NO_FINALIZER_closure);
 293   }
 294
 295   // kill it
 296 #ifdef PROFILING
 297   // @LDV profiling
 298   // A weak pointer is inherently used, so we do not need to call
 299   // LDV_recordDead_FILL_SLOP_DYNAMIC():
 300   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
 301   // or, LDV_recordDead():
 302   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
 303   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
 304   // large as weak pointers, so there is no need to fill the slop, either.
 305   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
 306 #endif
 307
 308   //
 309   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
 310   //
 311   SET_INFO(w,stg_DEAD_WEAK_info);
 312   LDV_RECORD_CREATE(w);
 313
 314   f = StgWeak_finalizer(w);
 315   StgDeadWeak_link(w) = StgWeak_link(w);
 316
 317   /* return the finalizer */
 318   if (f == stg_NO_FINALIZER_closure) {
 319       RET_NP(0,stg_NO_FINALIZER_closure);
 320   } else {
 321       RET_NP(1,f);
 322   }
 323 }
 324
 325 deRefWeakzh_fast
 326 {
 327   /* R1 = weak ptr */
 328   W_ w, code, val;
 329
 330   w = R1;
 331   if (GET_INFO(w) == stg_WEAK_info) {
 332     code = 1;
 333     val = StgWeak_value(w);
 334   } else {
 335     code = 0;
 336     val = w;
 337   }
 338   RET_NP(code,val);
 339 }
 340
 341 /* -----------------------------------------------------------------------------
 342    Arbitrary-precision Integer operations.
 343
 344    There are some assumptions in this code that mp_limb_t == W_.  This is
 345    the case for all the platforms that GHC supports, currently.
 346    -------------------------------------------------------------------------- */
 347
 348 int2Integerzh_fast
 349 {
 350    /* arguments: R1 = Int# */
 351
 352    W_ val, s, p;        /* to avoid aliasing */
 353
 354    val = R1;
 355    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, int2Integerzh_fast );
 356
 357    p = Hp - SIZEOF_StgArrWords;
 358    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 359    StgArrWords_words(p) = 1;
 360
 361    /* mpz_set_si is inlined here, makes things simpler */
 362    if (%lt(val,0)) {
 363         s  = -1;
 364         Hp(0) = -val;
 365    } else {
 366      if (%gt(val,0)) {
 367         s = 1;
 368         Hp(0) = val;
 369      } else {
 370         s = 0;
 371      }
 372   }
 373
 374    /* returns (# size  :: Int#,
 375                  data  :: ByteArray#
 376                #)
 377    */
 378    RET_NP(s,p);
 379 }
 380
 381 word2Integerzh_fast
 382 {
 383    /* arguments: R1 = Word# */
 384
 385    W_ val, s, p;        /* to avoid aliasing */
 386
 387    val = R1;
 388
 389    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, word2Integerzh_fast);
 390
 391    p = Hp - SIZEOF_StgArrWords;
 392    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 393    StgArrWords_words(p) = 1;
 394
 395    if (val != 0) {
 396         s = 1;
 397         W_[Hp] = val;
 398    } else {
 399         s = 0;
 400    }
 401
 402    /* returns (# size  :: Int#,
 403                  data  :: ByteArray# #)
 404    */
 405    RET_NP(s,p);
 406 }
 407
 408
 409 /*
 410  * 'long long' primops for converting to/from Integers.
 411  */
 412
 413 #ifdef SUPPORT_LONG_LONGS
 414
 415 int64ToIntegerzh_fast
 416 {
 417    /* arguments: L1 = Int64# */
 418
 419    L_ val;
 420    W_ hi, s, neg, words_needed, p;
 421
 422    val = L1;
 423    neg = 0;
 424
 425    if ( %ge(val,0x100000000::L_) || %le(val,-0x100000000::L_) )  {
 426        words_needed = 2;
 427    } else {
 428        // minimum is one word
 429        words_needed = 1;
 430    }
 431
 432    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
 433                NO_PTRS, int64ToIntegerzh_fast );
 434
 435    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
 436    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 437    StgArrWords_words(p) = words_needed;
 438
 439    if ( %lt(val,0::L_) ) {
 440      neg = 1;
 441      val = -val;
 442    }
 443
 444    hi = TO_W_(val >> 32);
 445
 446    if ( words_needed == 2 )  {
 447       s = 2;
 448       Hp(-1) = TO_W_(val);
 449       Hp(0) = hi;
 450    } else {
 451        if ( val != 0::L_ ) {
 452            s = 1;
 453            Hp(0) = TO_W_(val);
 454        } else /* val==0 */  {
 455            s = 0;
 456        }
 457    }
 458    if ( neg != 0 ) {
 459         s = -s;
 460    }
 461
 462    /* returns (# size  :: Int#,
 463                  data  :: ByteArray# #)
 464    */
 465    RET_NP(s,p);
 466 }
 467
 468 word64ToIntegerzh_fast
 469 {
 470    /* arguments: L1 = Word64# */
 471
 472    L_ val;
 473    W_ hi, s, words_needed, p;
 474
 475    val = L1;
 476    if ( val >= 0x100000000::L_ ) {
 477       words_needed = 2;
 478    } else {
 479       words_needed = 1;
 480    }
 481
 482    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
 483                NO_PTRS, word64ToIntegerzh_fast );
 484
 485    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
 486    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 487    StgArrWords_words(p) = words_needed;
 488
 489    hi = TO_W_(val >> 32);
 490    if ( val >= 0x100000000::L_ ) {
 491      s = 2;
 492      Hp(-1) = TO_W_(val);
 493      Hp(0)  = hi;
 494    } else {
 495       if ( val != 0::L_ ) {
 496         s = 1;
 497         Hp(0) = TO_W_(val);
 498      } else /* val==0 */  {
 499       s = 0;
 500      }
 501   }
 502
 503    /* returns (# size  :: Int#,
 504                  data  :: ByteArray# #)
 505    */
 506    RET_NP(s,p);
 507 }
 508
 509
 510 #endif /* SUPPORT_LONG_LONGS */
 511
 512 /* ToDo: this is shockingly inefficient */
 513
 514 #ifndef SMP
 515 section "bss" {
 516   mp_tmp1:
 517     bits8 [SIZEOF_MP_INT];
 518 }
 519
 520 section "bss" {
 521   mp_tmp2:
 522     bits8 [SIZEOF_MP_INT];
 523 }
 524
 525 section "bss" {
 526   mp_result1:
 527     bits8 [SIZEOF_MP_INT];
 528 }
 529
 530 section "bss" {
 531   mp_result2:
 532     bits8 [SIZEOF_MP_INT];
 533 }
 534 #endif
 535
 536 #ifdef SMP
 537 #define FETCH_MP_TEMP(X) \
 538 W_ X; \
 539 X = BaseReg + (OFFSET_StgRegTable_r ## X);
 540 #else
 541 #define FETCH_MP_TEMP(X) /* Nothing */
 542 #endif
 543
 544 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 545 name                                                                    \
 546 {                                                                       \
 547   CInt s1, s2;                                                          \
 548   W_ d1, d2;                                                            \
 549   FETCH_MP_TEMP(mp_tmp1);                                               \
 550   FETCH_MP_TEMP(mp_tmp2);                                               \
 551   FETCH_MP_TEMP(mp_result1)                                             \
 552   FETCH_MP_TEMP(mp_result2);                                            \
 553                                                                         \
 554   /* call doYouWantToGC() */                                            \
 555   MAYBE_GC(R2_PTR & R4_PTR, name);                                      \
 556                                                                         \
 557   s1 = W_TO_INT(R1);                                                    \
 558   d1 = R2;                                                              \
 559   s2 = W_TO_INT(R3);                                                    \
 560   d2 = R4;                                                              \
 561                                                                         \
 562   MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1));          \
 563   MP_INT__mp_size(mp_tmp1)  = (s1);                                     \
 564   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);                         \
 565   MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2));          \
 566   MP_INT__mp_size(mp_tmp2)  = (s2);                                     \
 567   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);                         \
 568                                                                         \
 569   foreign "C" mpz_init(mp_result1 "ptr") [];                            \
 570                                                                         \
 571   /* Perform the operation */                                           \
 572   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1  "ptr",mp_tmp2  "ptr") []; \
 573                                                                         \
 574   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
 575          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
 576 }
 577
 578 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
 579 name                                                                    \
 580 {                                                                       \
 581   CInt s1;                                                              \
 582   W_ d1;                                                                \
 583   FETCH_MP_TEMP(mp_tmp1);                                               \
 584   FETCH_MP_TEMP(mp_result1)                                             \
 585                                                                         \
 586   /* call doYouWantToGC() */                                            \
 587   MAYBE_GC(R2_PTR, name);                                               \
 588                                                                         \
 589   d1 = R2;                                                              \
 590   s1 = W_TO_INT(R1);                                                    \
 591                                                                         \
 592   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));      \
 593   MP_INT__mp_size(mp_tmp1)      = (s1);                                 \
 594   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                     \
 595                                                                         \
 596   foreign "C" mpz_init(mp_result1 "ptr") [];                            \
 597                                                                         \
 598   /* Perform the operation */                                           \
 599   foreign "C" mp_fun(mp_result1 "ptr",mp_tmp1 "ptr") [];                \
 600                                                                         \
 601   RET_NP(TO_W_(MP_INT__mp_size(mp_result1)),                            \
 602          MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords);                \
 603 }
 604
 605 #define GMP_TAKE2_RET2(name,mp_fun)                                                     \
 606 name                                                                                    \
 607 {                                                                                       \
 608   CInt s1, s2;                                                                          \
 609   W_ d1, d2;                                                                            \
 610   FETCH_MP_TEMP(mp_tmp1);                                                               \
 611   FETCH_MP_TEMP(mp_tmp2);                                                               \
 612   FETCH_MP_TEMP(mp_result1)                                                             \
 613   FETCH_MP_TEMP(mp_result2)                                                             \
 614                                                                                         \
 615   /* call doYouWantToGC() */                                                            \
 616   MAYBE_GC(R2_PTR & R4_PTR, name);                                                      \
 617                                                                                         \
 618   s1 = W_TO_INT(R1);                                                                    \
 619   d1 = R2;                                                                              \
 620   s2 = W_TO_INT(R3);                                                                    \
 621   d2 = R4;                                                                              \
 622                                                                                         \
 623   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));                      \
 624   MP_INT__mp_size(mp_tmp1)      = (s1);                                                 \
 625   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);                                     \
 626   MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(StgArrWords_words(d2));                      \
 627   MP_INT__mp_size(mp_tmp2)      = (s2);                                                 \
 628   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);                                     \
 629                                                                                         \
 630   foreign "C" mpz_init(mp_result1 "ptr") [];                                               \
 631   foreign "C" mpz_init(mp_result2 "ptr") [];                                               \
 632                                                                                         \
 633   /* Perform the operation */                                                           \
 634   foreign "C" mp_fun(mp_result1 "ptr",mp_result2 "ptr",mp_tmp1 "ptr",mp_tmp2 "ptr") [];    \
 635                                                                                         \
 636   RET_NPNP(TO_W_(MP_INT__mp_size(mp_result1)),                                          \
 637            MP_INT__mp_d(mp_result1) - SIZEOF_StgArrWords,                               \
 638            TO_W_(MP_INT__mp_size(mp_result2)),                                          \
 639            MP_INT__mp_d(mp_result2) - SIZEOF_StgArrWords);                              \
 640 }
 641
 642 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add)
 643 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub)
 644 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul)
 645 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd)
 646 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q)
 647 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r)
 648 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact)
 649 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and)
 650 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior)
 651 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor)
 652 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com)
 653
 654 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr)
 655 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr)
 656
 657 #ifndef SMP
 658 section "bss" {
 659   mp_tmp_w:  W_; // NB. mp_tmp_w is really an here mp_limb_t
 660 }
 661 #endif
 662
 663 gcdIntzh_fast
 664 {
 665     /* R1 = the first Int#; R2 = the second Int# */
 666     W_ r;
 667     FETCH_MP_TEMP(mp_tmp_w);
 668
 669     W_[mp_tmp_w] = R1;
 670     r = foreign "C" mpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
 671
 672     R1 = r;
 673     /* Result parked in R1, return via info-pointer at TOS */
 674     jump %ENTRY_CODE(Sp(0));
 675 }
 676
 677
 678 gcdIntegerIntzh_fast
 679 {
 680     /* R1 = s1; R2 = d1; R3 = the int */
 681     R1 = foreign "C" mpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
 682
 683     /* Result parked in R1, return via info-pointer at TOS */
 684     jump %ENTRY_CODE(Sp(0));
 685 }
 686
 687
 688 cmpIntegerIntzh_fast
 689 {
 690     /* R1 = s1; R2 = d1; R3 = the int */
 691     W_ usize, vsize, v_digit, u_digit;
 692
 693     usize = R1;
 694     vsize = 0;
 695     v_digit = R3;
 696
 697     // paraphrased from mpz_cmp_si() in the GMP sources
 698     if (%gt(v_digit,0)) {
 699         vsize = 1;
 700     } else {
 701         if (%lt(v_digit,0)) {
 702             vsize = -1;
 703             v_digit = -v_digit;
 704         }
 705     }
 706
 707     if (usize != vsize) {
 708         R1 = usize - vsize;
 709         jump %ENTRY_CODE(Sp(0));
 710     }
 711
 712     if (usize == 0) {
 713         R1 = 0;
 714         jump %ENTRY_CODE(Sp(0));
 715     }
 716
 717     u_digit = W_[BYTE_ARR_CTS(R2)];
 718
 719     if (u_digit == v_digit) {
 720         R1 = 0;
 721         jump %ENTRY_CODE(Sp(0));
 722     }
 723
 724     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
 725         R1 = usize;
 726     } else {
 727         R1 = -usize;
 728     }
 729
 730     jump %ENTRY_CODE(Sp(0));
 731 }
 732
 733 cmpIntegerzh_fast
 734 {
 735     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
 736     W_ usize, vsize, size, up, vp;
 737     CInt cmp;
 738
 739     // paraphrased from mpz_cmp() in the GMP sources
 740     usize = R1;
 741     vsize = R3;
 742
 743     if (usize != vsize) {
 744         R1 = usize - vsize;
 745         jump %ENTRY_CODE(Sp(0));
 746     }
 747
 748     if (usize == 0) {
 749         R1 = 0;
 750         jump %ENTRY_CODE(Sp(0));
 751     }
 752
 753     if (%lt(usize,0)) { // NB. not <, which is unsigned
 754         size = -usize;
 755     } else {
 756         size = usize;
 757     }
 758
 759     up = BYTE_ARR_CTS(R2);
 760     vp = BYTE_ARR_CTS(R4);
 761
 762     cmp = foreign "C" mpn_cmp(up "ptr", vp "ptr", size) [];
 763
 764     if (cmp == 0 :: CInt) {
 765         R1 = 0;
 766         jump %ENTRY_CODE(Sp(0));
 767     }
 768
 769     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
 770         R1 = 1;
 771     } else {
 772         R1 = (-1);
 773     }
 774     /* Result parked in R1, return via info-pointer at TOS */
 775     jump %ENTRY_CODE(Sp(0));
 776 }
 777
 778 integer2Intzh_fast
 779 {
 780     /* R1 = s; R2 = d */
 781     W_ r, s;
 782
 783     s = R1;
 784     if (s == 0) {
 785         r = 0;
 786     } else {
 787         r = W_[R2 + SIZEOF_StgArrWords];
 788         if (%lt(s,0)) {
 789             r = -r;
 790         }
 791     }
 792     /* Result parked in R1, return via info-pointer at TOS */
 793     R1 = r;
 794     jump %ENTRY_CODE(Sp(0));
 795 }
 796
 797 integer2Wordzh_fast
 798 {
 799   /* R1 = s; R2 = d */
 800   W_ r, s;
 801
 802   s = R1;
 803   if (s == 0) {
 804     r = 0;
 805   } else {
 806     r = W_[R2 + SIZEOF_StgArrWords];
 807     if (%lt(s,0)) {
 808         r = -r;
 809     }
 810   }
 811   /* Result parked in R1, return via info-pointer at TOS */
 812   R1 = r;
 813   jump %ENTRY_CODE(Sp(0));
 814 }
 815
 816 decodeFloatzh_fast
 817 {
 818     W_ p;
 819     F_ arg;
 820     FETCH_MP_TEMP(mp_tmp1);
 821     FETCH_MP_TEMP(mp_tmp_w);
 822
 823     /* arguments: F1 = Float# */
 824     arg = F1;
 825
 826     ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, decodeFloatzh_fast );
 827
 828     /* Be prepared to tell Lennart-coded __decodeFloat
 829        where mantissa._mp_d can be put (it does not care about the rest) */
 830     p = Hp - SIZEOF_StgArrWords;
 831     SET_HDR(p,stg_ARR_WORDS_info,W_[CCCS]);
 832     StgArrWords_words(p) = 1;
 833     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 834
 835     /* Perform the operation */
 836     foreign "C" __decodeFloat(mp_tmp1 "ptr",mp_tmp_w "ptr" ,arg) [];
 837
 838     /* returns: (Int# (expn), Int#, ByteArray#) */
 839     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 840 }
 841
 842 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
 843 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
 844
 845 decodeDoublezh_fast
 846 {
 847     D_ arg;
 848     W_ p;
 849     FETCH_MP_TEMP(mp_tmp1);
 850     FETCH_MP_TEMP(mp_tmp_w);
 851
 852     /* arguments: D1 = Double# */
 853     arg = D1;
 854
 855     ALLOC_PRIM( ARR_SIZE, NO_PTRS, decodeDoublezh_fast );
 856
 857     /* Be prepared to tell Lennart-coded __decodeDouble
 858        where mantissa.d can be put (it does not care about the rest) */
 859     p = Hp - ARR_SIZE + WDS(1);
 860     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 861     StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
 862     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 863
 864     /* Perform the operation */
 865     foreign "C" __decodeDouble(mp_tmp1 "ptr", mp_tmp_w "ptr",arg) [];
 866
 867     /* returns: (Int# (expn), Int#, ByteArray#) */
 868     RET_NNP(W_[mp_tmp_w], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 869 }
 870
 871 /* -----------------------------------------------------------------------------
 872  * Concurrency primitives
 873  * -------------------------------------------------------------------------- */
 874
 875 forkzh_fast
 876 {
 877   /* args: R1 = closure to spark */
 878
 879   MAYBE_GC(R1_PTR, forkzh_fast);
 880
 881   // create it right now, return ThreadID in R1
 882   "ptr" R1 = foreign "C" createIOThread( MyCapability() "ptr",
 883                                 RtsFlags_GcFlags_initialStkSize(RtsFlags),
 884                                 R1 "ptr");
 885   foreign "C" scheduleThread(MyCapability() "ptr", R1 "ptr");
 886
 887   // switch at the earliest opportunity
 888   CInt[context_switch] = 1 :: CInt;
 889
 890   RET_P(R1);
 891 }
 892
 893 yieldzh_fast
 894 {
 895   jump stg_yield_noregs;
 896 }
 897
 898 myThreadIdzh_fast
 899 {
 900   /* no args. */
 901   RET_P(CurrentTSO);
 902 }
 903
 904 labelThreadzh_fast
 905 {
 906   /* args:
 907         R1 = ThreadId#
 908         R2 = Addr# */
 909 #ifdef DEBUG
 910   foreign "C" labelThread(R1 "ptr", R2 "ptr");
 911 #endif
 912   jump %ENTRY_CODE(Sp(0));
 913 }
 914
 915 isCurrentThreadBoundzh_fast
 916 {
 917   /* no args */
 918   W_ r;
 919   r = foreign "C" isThreadBound(CurrentTSO) [];
 920   RET_N(r);
 921 }
 922
 923
 924 /* -----------------------------------------------------------------------------
 925  * TVar primitives
 926  * -------------------------------------------------------------------------- */
 927
 928 #ifdef REG_R1
 929 #define SP_OFF 0
 930 #define IF_NOT_REG_R1(x)
 931 #else
 932 #define SP_OFF 1
 933 #define IF_NOT_REG_R1(x) x
 934 #endif
 935
 936 // Catch retry frame ------------------------------------------------------------
 937
 938 #define CATCH_RETRY_FRAME_ERROR(label) \
 939   label { foreign "C" barf("catch_retry_frame incorrectly entered!"); }
 940
 941 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_0_ret)
 942 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_1_ret)
 943 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_2_ret)
 944 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_3_ret)
 945 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_4_ret)
 946 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_5_ret)
 947 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_6_ret)
 948 CATCH_RETRY_FRAME_ERROR(stg_catch_retry_frame_7_ret)
 949
 950 #if MAX_VECTORED_RTN > 8
 951 #error MAX_VECTORED_RTN has changed: please modify stg_catch_retry_frame too.
 952 #endif
 953
 954 #if defined(PROFILING)
 955 #define CATCH_RETRY_FRAME_BITMAP 7
 956 #define CATCH_RETRY_FRAME_WORDS  6
 957 #else
 958 #define CATCH_RETRY_FRAME_BITMAP 1
 959 #define CATCH_RETRY_FRAME_WORDS  4
 960 #endif
 961
 962 INFO_TABLE_RET(stg_catch_retry_frame,
 963                CATCH_RETRY_FRAME_WORDS, CATCH_RETRY_FRAME_BITMAP,
 964                CATCH_RETRY_FRAME,
 965                stg_catch_retry_frame_0_ret,
 966                stg_catch_retry_frame_1_ret,
 967                stg_catch_retry_frame_2_ret,
 968                stg_catch_retry_frame_3_ret,
 969                stg_catch_retry_frame_4_ret,
 970                stg_catch_retry_frame_5_ret,
 971                stg_catch_retry_frame_6_ret,
 972                stg_catch_retry_frame_7_ret)
 973 {
 974    W_ r, frame, trec, outer;
 975    IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
 976
 977    frame = Sp;
 978    trec = StgTSO_trec(CurrentTSO);
 979    "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
 980    r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
 981    if (r) {
 982      /* Succeeded (either first branch or second branch) */
 983      StgTSO_trec(CurrentTSO) = outer;
 984      Sp = Sp + SIZEOF_StgCatchRetryFrame;
 985      IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
 986      jump %ENTRY_CODE(Sp(SP_OFF));
 987    } else {
 988      /* Did not commit: retry */
 989      W_ new_trec;
 990      "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
 991      StgTSO_trec(CurrentTSO) = new_trec;
 992      if (StgCatchRetryFrame_running_alt_code(frame)) {
 993        R1 = StgCatchRetryFrame_alt_code(frame);
 994      } else {
 995        R1 = StgCatchRetryFrame_first_code(frame);
 996        StgCatchRetryFrame_first_code_trec(frame) = new_trec;
 997      }
 998      Sp_adj(-1);
 999      jump RET_LBL(stg_ap_v);
1000    }
1001 }
1002
1003
1004 // Atomically frame -------------------------------------------------------------
1005
1006
1007 #define ATOMICALLY_FRAME_ERROR(label) \
1008   label { foreign "C" barf("atomically_frame incorrectly entered!"); }
1009
1010 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_0_ret)
1011 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_1_ret)
1012 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_2_ret)
1013 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_3_ret)
1014 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_4_ret)
1015 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_5_ret)
1016 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_6_ret)
1017 ATOMICALLY_FRAME_ERROR(stg_atomically_frame_7_ret)
1018
1019 #if MAX_VECTORED_RTN > 8
1020 #error MAX_VECTORED_RTN has changed: please modify stg_atomically_frame too.
1021 #endif
1022
1023 #if defined(PROFILING)
1024 #define ATOMICALLY_FRAME_BITMAP 7
1025 #define ATOMICALLY_FRAME_WORDS  4
1026 #else
1027 #define ATOMICALLY_FRAME_BITMAP 1
1028 #define ATOMICALLY_FRAME_WORDS  2
1029 #endif
1030
1031
1032 INFO_TABLE_RET(stg_atomically_frame,
1033                ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP,
1034                ATOMICALLY_FRAME,
1035                stg_atomically_frame_0_ret,
1036                stg_atomically_frame_1_ret,
1037                stg_atomically_frame_2_ret,
1038                stg_atomically_frame_3_ret,
1039                stg_atomically_frame_4_ret,
1040                stg_atomically_frame_5_ret,
1041                stg_atomically_frame_6_ret,
1042                stg_atomically_frame_7_ret)
1043 {
1044    W_ frame, trec, valid;
1045    IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
1046
1047    frame = Sp;
1048    trec = StgTSO_trec(CurrentTSO);
1049    if (StgAtomicallyFrame_waiting(frame)) {
1050      /* The TSO is currently waiting: should we stop waiting? */
1051      valid = foreign "C" stmReWait(CurrentTSO "ptr");
1052      if (valid) {
1053        /* Previous attempt is still valid: no point trying again yet */
1054           IF_NOT_REG_R1(Sp_adj(-2);
1055                         Sp(1) = stg_NO_FINALIZER_closure;
1056                         Sp(0) = stg_ut_1_0_unreg_info;)
1057        jump stg_block_noregs;
1058      } else {
1059        /* Previous attempt is no longer valid: try again */
1060        "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
1061        StgTSO_trec(CurrentTSO) = trec;
1062        StgAtomicallyFrame_waiting(frame) = 0 :: CInt; /* false; */
1063        R1 = StgAtomicallyFrame_code(frame);
1064        Sp_adj(-1);
1065        jump RET_LBL(stg_ap_v);
1066      }
1067    } else {
1068      /* The TSO is not currently waiting: try to commit the transaction */
1069      valid = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr");
1070      if (valid) {
1071        /* Transaction was valid: commit succeeded */
1072        StgTSO_trec(CurrentTSO) = NO_TREC;
1073        Sp = Sp + SIZEOF_StgAtomicallyFrame;
1074        IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
1075        jump %ENTRY_CODE(Sp(SP_OFF));
1076      } else {
1077        /* Transaction was not valid: try again */
1078        "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
1079        StgTSO_trec(CurrentTSO) = trec;
1080        R1 = StgAtomicallyFrame_code(frame);
1081        Sp_adj(-1);
1082        jump RET_LBL(stg_ap_v);
1083      }
1084    }
1085 }
1086
1087
1088 // STM catch frame --------------------------------------------------------------
1089
1090 #define CATCH_STM_FRAME_ENTRY_TEMPLATE(label,ret)          \
1091    label                                                   \
1092    {                                                       \
1093       IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )  \
1094       Sp = Sp + SIZEOF_StgCatchSTMFrame;                   \
1095       IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)             \
1096       jump ret;                                            \
1097    }
1098
1099 #ifdef REG_R1
1100 #define SP_OFF 0
1101 #else
1102 #define SP_OFF 1
1103 #endif
1104
1105 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
1106 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
1107 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
1108 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
1109 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
1110 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
1111 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
1112 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
1113
1114 #if MAX_VECTORED_RTN > 8
1115 #error MAX_VECTORED_RTN has changed: please modify stg_catch_stm_frame too.
1116 #endif
1117
1118 #if defined(PROFILING)
1119 #define CATCH_STM_FRAME_BITMAP 3
1120 #define CATCH_STM_FRAME_WORDS  3
1121 #else
1122 #define CATCH_STM_FRAME_BITMAP 0
1123 #define CATCH_STM_FRAME_WORDS  1
1124 #endif
1125
1126 /* Catch frames are very similar to update frames, but when entering
1127  * one we just pop the frame off the stack and perform the correct
1128  * kind of return to the activation record underneath us on the stack.
1129  */
1130
1131 INFO_TABLE_RET(stg_catch_stm_frame,
1132                CATCH_STM_FRAME_WORDS, CATCH_STM_FRAME_BITMAP,
1133                CATCH_STM_FRAME,
1134                stg_catch_stm_frame_0_ret,
1135                stg_catch_stm_frame_1_ret,
1136                stg_catch_stm_frame_2_ret,
1137                stg_catch_stm_frame_3_ret,
1138                stg_catch_stm_frame_4_ret,
1139                stg_catch_stm_frame_5_ret,
1140                stg_catch_stm_frame_6_ret,
1141                stg_catch_stm_frame_7_ret)
1142 CATCH_STM_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
1143
1144
1145 // Primop definition ------------------------------------------------------------
1146
1147 atomicallyzh_fast
1148 {
1149   W_ frame;
1150   W_ old_trec;
1151   W_ new_trec;
1152
1153   // stmStartTransaction may allocate
1154   MAYBE_GC (R1_PTR, atomicallyzh_fast);
1155
1156   /* Args: R1 = m :: STM a */
1157   STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, atomicallyzh_fast);
1158
1159   /* Set up the atomically frame */
1160   Sp = Sp - SIZEOF_StgAtomicallyFrame;
1161   frame = Sp;
1162
1163   SET_HDR(frame,stg_atomically_frame_info, W_[CCCS]);
1164   StgAtomicallyFrame_waiting(frame) = 0 :: CInt; // False
1165   StgAtomicallyFrame_code(frame) = R1;
1166
1167   /* Start the memory transcation */
1168   old_trec = StgTSO_trec(CurrentTSO);
1169   ASSERT(old_trec == NO_TREC);
1170   "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
1171   StgTSO_trec(CurrentTSO) = new_trec;
1172
1173   /* Apply R1 to the realworld token */
1174   Sp_adj(-1);
1175   jump RET_LBL(stg_ap_v);
1176 }
1177
1178
1179 catchSTMzh_fast
1180 {
1181   W_ frame;
1182
1183   /* Args: R1 :: STM a */
1184   /* Args: R2 :: Exception -> STM a */
1185   STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, catchSTMzh_fast);
1186
1187   /* Set up the catch frame */
1188   Sp = Sp - SIZEOF_StgCatchSTMFrame;
1189   frame = Sp;
1190
1191   SET_HDR(frame, stg_catch_stm_frame_info, W_[CCCS]);
1192   StgCatchSTMFrame_handler(frame) = R2;
1193
1194   /* Apply R1 to the realworld token */
1195   Sp_adj(-1);
1196   jump RET_LBL(stg_ap_v);
1197 }
1198
1199
1200 catchRetryzh_fast
1201 {
1202   W_ frame;
1203   W_ new_trec;
1204   W_ trec;
1205
1206   // stmStartTransaction may allocate
1207   MAYBE_GC (R1_PTR & R2_PTR, catchRetryzh_fast);
1208
1209   /* Args: R1 :: STM a */
1210   /* Args: R2 :: STM a */
1211   STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, catchRetryzh_fast);
1212
1213   /* Start a nested transaction within which to run the first code */
1214   trec = StgTSO_trec(CurrentTSO);
1215   "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr");
1216   StgTSO_trec(CurrentTSO) = new_trec;
1217
1218   /* Set up the catch-retry frame */
1219   Sp = Sp - SIZEOF_StgCatchRetryFrame;
1220   frame = Sp;
1221
1222   SET_HDR(frame, stg_catch_retry_frame_info, W_[CCCS]);
1223   StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
1224   StgCatchRetryFrame_first_code(frame) = R1;
1225   StgCatchRetryFrame_alt_code(frame) = R2;
1226   StgCatchRetryFrame_first_code_trec(frame) = new_trec;
1227
1228   /* Apply R1 to the realworld token */
1229   Sp_adj(-1);
1230   jump RET_LBL(stg_ap_v);
1231 }
1232
1233
1234 retryzh_fast
1235 {
1236   W_ frame_type;
1237   W_ frame;
1238   W_ trec;
1239   W_ outer;
1240   W_ r;
1241
1242   MAYBE_GC (NO_PTRS, retryzh_fast); // STM operations may allocate
1243
1244   // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
1245 retry_pop_stack:
1246   trec = StgTSO_trec(CurrentTSO);
1247   "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr");
1248   StgTSO_sp(CurrentTSO) = Sp;
1249   frame_type = foreign "C" findRetryFrameHelper(CurrentTSO "ptr");
1250   Sp = StgTSO_sp(CurrentTSO);
1251   frame = Sp;
1252
1253   if (frame_type == CATCH_RETRY_FRAME) {
1254     // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
1255     ASSERT(outer != NO_TREC);
1256     if (!StgCatchRetryFrame_running_alt_code(frame)) {
1257       // Retry in the first code: try the alternative
1258       "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1259       StgTSO_trec(CurrentTSO) = trec;
1260       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
1261       R1 = StgCatchRetryFrame_alt_code(frame);
1262       Sp_adj(-1);
1263       jump RET_LBL(stg_ap_v);
1264     } else {
1265       // Retry in the alternative code: propagate
1266       W_ other_trec;
1267       other_trec = StgCatchRetryFrame_first_code_trec(frame);
1268       r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", other_trec "ptr");
1269       if (r) {
1270         r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
1271       }
1272       if (r) {
1273         // Merge between siblings succeeded: commit it back to enclosing transaction
1274         // and then propagate the retry
1275         StgTSO_trec(CurrentTSO) = outer;
1276         Sp = Sp + SIZEOF_StgCatchRetryFrame;
1277         goto retry_pop_stack;
1278       } else {
1279         // Merge failed: we musn't propagate the retry.  Try both paths again.
1280         "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1281         StgCatchRetryFrame_first_code_trec(frame) = trec;
1282         StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
1283         StgTSO_trec(CurrentTSO) = trec;
1284         R1 = StgCatchRetryFrame_first_code(frame);
1285         Sp_adj(-1);
1286         jump RET_LBL(stg_ap_v);
1287       }
1288     }
1289   }
1290
1291   // We've reached the ATOMICALLY_FRAME: attempt to wait
1292   ASSERT(frame_type == ATOMICALLY_FRAME);
1293   ASSERT(outer == NO_TREC);
1294   r = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
1295   if (r) {
1296     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1297     StgAtomicallyFrame_waiting(frame) = 1 :: CInt; // true
1298     Sp = frame;
1299     // Fix up the stack in the unregisterised case: the return convention is different.
1300     IF_NOT_REG_R1(Sp_adj(-2);
1301                   Sp(1) = stg_NO_FINALIZER_closure;
1302                   Sp(0) = stg_ut_1_0_unreg_info;)
1303     jump stg_block_noregs;
1304   } else {
1305     // Transaction was not valid: retry immediately
1306     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1307     StgTSO_trec(CurrentTSO) = trec;
1308     R1 = StgAtomicallyFrame_code(frame);
1309     Sp = frame;
1310     Sp_adj(-1);
1311     jump RET_LBL(stg_ap_v);
1312   }
1313 }
1314
1315
1316 newTVarzh_fast
1317 {
1318   W_ tv;
1319   W_ new_value;
1320
1321   /* Args: R1 = initialisation value */
1322
1323   MAYBE_GC (R1_PTR, newTVarzh_fast);
1324   new_value = R1;
1325   "ptr" tv = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr");
1326   RET_P(tv);
1327 }
1328
1329
1330 readTVarzh_fast
1331 {
1332   W_ trec;
1333   W_ tvar;
1334   W_ result;
1335
1336   /* Args: R1 = TVar closure */
1337
1338   MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate
1339   trec = StgTSO_trec(CurrentTSO);
1340   tvar = R1;
1341   "ptr" result = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
1342
1343   RET_P(result);
1344 }
1345
1346
1347 writeTVarzh_fast
1348 {
1349   W_ trec;
1350   W_ tvar;
1351   W_ new_value;
1352
1353   /* Args: R1 = TVar closure */
1354   /*       R2 = New value    */
1355
1356   MAYBE_GC (R1_PTR & R2_PTR, writeTVarzh_fast); // Call to stmWriteTVar may allocate
1357   trec = StgTSO_trec(CurrentTSO);
1358   tvar = R1;
1359   new_value = R2;
1360   foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
1361
1362   jump %ENTRY_CODE(Sp(0));
1363 }
1364
1365
1366 /* -----------------------------------------------------------------------------
1367  * MVar primitives
1368  *
1369  * take & putMVar work as follows.  Firstly, an important invariant:
1370  *
1371  *    If the MVar is full, then the blocking queue contains only
1372  *    threads blocked on putMVar, and if the MVar is empty then the
1373  *    blocking queue contains only threads blocked on takeMVar.
1374  *
1375  * takeMvar:
1376  *    MVar empty : then add ourselves to the blocking queue
1377  *    MVar full  : remove the value from the MVar, and
1378  *                 blocking queue empty     : return
1379  *                 blocking queue non-empty : perform the first blocked putMVar
1380  *                                            from the queue, and wake up the
1381  *                                            thread (MVar is now full again)
1382  *
1383  * putMVar is just the dual of the above algorithm.
1384  *
1385  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1386  * the stack of the thread waiting to do the putMVar.  See
1387  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1388  * the stack layout, and the PerformPut and PerformTake macros below.
1389  *
1390  * It is important that a blocked take or put is woken up with the
1391  * take/put already performed, because otherwise there would be a
1392  * small window of vulnerability where the thread could receive an
1393  * exception and never perform its take or put, and we'd end up with a
1394  * deadlock.
1395  *
1396  * -------------------------------------------------------------------------- */
1397
1398 isEmptyMVarzh_fast
1399 {
1400     /* args: R1 = MVar closure */
1401
1402     if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
1403         RET_N(1);
1404     } else {
1405         RET_N(0);
1406     }
1407 }
1408
1409 newMVarzh_fast
1410 {
1411     /* args: none */
1412     W_ mvar;
1413
1414     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
1415
1416     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1417     SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
1418     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1419     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1420     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1421     RET_P(mvar);
1422 }
1423
1424
1425 /* If R1 isn't available, pass it on the stack */
1426 #ifdef REG_R1
1427 #define PerformTake(tso, value)                         \
1428     W_[StgTSO_sp(tso) + WDS(1)] = value;                \
1429     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
1430 #else
1431 #define PerformTake(tso, value)                                 \
1432     W_[StgTSO_sp(tso) + WDS(1)] = value;                        \
1433     W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
1434 #endif
1435
1436 #define PerformPut(tso,lval)                    \
1437     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);   \
1438     lval = W_[StgTSO_sp(tso) - WDS(1)];
1439
1440 takeMVarzh_fast
1441 {
1442     W_ mvar, val, info, tso;
1443
1444     /* args: R1 = MVar closure */
1445     mvar = R1;
1446
1447 #if defined(SMP)
1448     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1449 #else
1450     info = GET_INFO(mvar);
1451 #endif
1452
1453     /* If the MVar is empty, put ourselves on its blocking queue,
1454      * and wait until we're woken up.
1455      */
1456     if (info == stg_EMPTY_MVAR_info) {
1457         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1458             StgMVar_head(mvar) = CurrentTSO;
1459         } else {
1460             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1461         }
1462         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1463         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1464         StgTSO_block_info(CurrentTSO)  = mvar;
1465         StgMVar_tail(mvar) = CurrentTSO;
1466
1467         jump stg_block_takemvar;
1468   }
1469
1470   /* we got the value... */
1471   val = StgMVar_value(mvar);
1472
1473   if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
1474   {
1475       /* There are putMVar(s) waiting...
1476        * wake up the first thread on the queue
1477        */
1478       ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1479
1480       /* actually perform the putMVar for the thread that we just woke up */
1481       tso = StgMVar_head(mvar);
1482       PerformPut(tso,StgMVar_value(mvar));
1483
1484 #if defined(GRAN) || defined(PAR)
1485       /* ToDo: check 2nd arg (mvar) is right */
1486       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
1487       StgMVar_head(mvar) = tso;
1488 #else
1489       "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1490                                          StgMVar_head(mvar) "ptr") [];
1491       StgMVar_head(mvar) = tso;
1492 #endif
1493
1494       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1495           StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1496       }
1497
1498 #if defined(SMP)
1499       foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1500 #endif
1501       RET_P(val);
1502   }
1503   else
1504   {
1505       /* No further putMVars, MVar is now empty */
1506       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1507
1508 #if defined(SMP)
1509       foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1510 #else
1511       SET_INFO(mvar,stg_EMPTY_MVAR_info);
1512 #endif
1513
1514       RET_P(val);
1515   }
1516 }
1517
1518
1519 tryTakeMVarzh_fast
1520 {
1521     W_ mvar, val, info, tso;
1522
1523     /* args: R1 = MVar closure */
1524
1525     mvar = R1;
1526
1527 #if defined(SMP)
1528     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1529 #else
1530     info = GET_INFO(mvar);
1531 #endif
1532
1533     if (info == stg_EMPTY_MVAR_info) {
1534 #if defined(SMP)
1535         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1536 #endif
1537         /* HACK: we need a pointer to pass back,
1538          * so we abuse NO_FINALIZER_closure
1539          */
1540         RET_NP(0, stg_NO_FINALIZER_closure);
1541     }
1542
1543     /* we got the value... */
1544     val = StgMVar_value(mvar);
1545
1546     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1547
1548         /* There are putMVar(s) waiting...
1549          * wake up the first thread on the queue
1550          */
1551         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1552
1553         /* actually perform the putMVar for the thread that we just woke up */
1554         tso = StgMVar_head(mvar);
1555         PerformPut(tso,StgMVar_value(mvar));
1556
1557 #if defined(GRAN) || defined(PAR)
1558         /* ToDo: check 2nd arg (mvar) is right */
1559         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
1560         StgMVar_head(mvar) = tso;
1561 #else
1562         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1563                                            StgMVar_head(mvar) "ptr") [];
1564         StgMVar_head(mvar) = tso;
1565 #endif
1566
1567         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1568             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1569         }
1570 #if defined(SMP)
1571         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1572 #endif
1573     }
1574     else
1575     {
1576         /* No further putMVars, MVar is now empty */
1577         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1578 #if defined(SMP)
1579         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1580 #else
1581         SET_INFO(mvar,stg_EMPTY_MVAR_info);
1582 #endif
1583     }
1584
1585     RET_NP(1, val);
1586 }
1587
1588
1589 putMVarzh_fast
1590 {
1591     W_ mvar, info, tso;
1592
1593     /* args: R1 = MVar, R2 = value */
1594     mvar = R1;
1595
1596 #if defined(SMP)
1597     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1598 #else
1599     info = GET_INFO(mvar);
1600 #endif
1601
1602     if (info == stg_FULL_MVAR_info) {
1603         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1604             StgMVar_head(mvar) = CurrentTSO;
1605         } else {
1606             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1607         }
1608         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1609         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1610         StgTSO_block_info(CurrentTSO)  = mvar;
1611         StgMVar_tail(mvar) = CurrentTSO;
1612
1613         jump stg_block_putmvar;
1614     }
1615
1616     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1617
1618         /* There are takeMVar(s) waiting: wake up the first one
1619          */
1620         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1621
1622         /* actually perform the takeMVar */
1623         tso = StgMVar_head(mvar);
1624         PerformTake(tso, R2);
1625
1626 #if defined(GRAN) || defined(PAR)
1627         /* ToDo: check 2nd arg (mvar) is right */
1628         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1629         StgMVar_head(mvar) = tso;
1630 #else
1631         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1632         StgMVar_head(mvar) = tso;
1633 #endif
1634
1635         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1636             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1637         }
1638
1639 #if defined(SMP)
1640         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1641 #endif
1642         jump %ENTRY_CODE(Sp(0));
1643     }
1644     else
1645     {
1646         /* No further takes, the MVar is now full. */
1647         StgMVar_value(mvar) = R2;
1648
1649 #if defined(SMP)
1650         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1651 #else
1652         SET_INFO(mvar,stg_FULL_MVAR_info);
1653 #endif
1654         jump %ENTRY_CODE(Sp(0));
1655     }
1656
1657     /* ToDo: yield afterward for better communication performance? */
1658 }
1659
1660
1661 tryPutMVarzh_fast
1662 {
1663     W_ mvar, info, tso;
1664
1665     /* args: R1 = MVar, R2 = value */
1666     mvar = R1;
1667
1668 #if defined(SMP)
1669     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1670 #else
1671     info = GET_INFO(mvar);
1672 #endif
1673
1674     if (info == stg_FULL_MVAR_info) {
1675 #if defined(SMP)
1676         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1677 #endif
1678         RET_N(0);
1679     }
1680
1681     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1682
1683         /* There are takeMVar(s) waiting: wake up the first one
1684          */
1685         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1686
1687         /* actually perform the takeMVar */
1688         tso = StgMVar_head(mvar);
1689         PerformTake(tso, R2);
1690
1691 #if defined(GRAN) || defined(PAR)
1692         /* ToDo: check 2nd arg (mvar) is right */
1693         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1694         StgMVar_head(mvar) = tso;
1695 #else
1696         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1697         StgMVar_head(mvar) = tso;
1698 #endif
1699
1700         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1701             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1702         }
1703
1704 #if defined(SMP)
1705         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1706 #endif
1707         jump %ENTRY_CODE(Sp(0));
1708     }
1709     else
1710     {
1711         /* No further takes, the MVar is now full. */
1712         StgMVar_value(mvar) = R2;
1713
1714 #if defined(SMP)
1715         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1716 #else
1717         SET_INFO(mvar,stg_FULL_MVAR_info);
1718 #endif
1719         jump %ENTRY_CODE(Sp(0));
1720     }
1721
1722     /* ToDo: yield afterward for better communication performance? */
1723 }
1724
1725
1726 /* -----------------------------------------------------------------------------
1727    Stable pointer primitives
1728    -------------------------------------------------------------------------  */
1729
1730 makeStableNamezh_fast
1731 {
1732     W_ index, sn_obj;
1733
1734     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
1735
1736     index = foreign "C" lookupStableName(R1 "ptr") [];
1737
1738     /* Is there already a StableName for this heap object?
1739      *  stable_ptr_table is a pointer to an array of snEntry structs.
1740      */
1741     if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
1742         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1743         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1744         StgStableName_sn(sn_obj) = index;
1745         snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
1746     } else {
1747         sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
1748     }
1749
1750     RET_P(sn_obj);
1751 }
1752
1753
1754 makeStablePtrzh_fast
1755 {
1756     /* Args: R1 = a */
1757     W_ sp;
1758     MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1759     "ptr" sp = foreign "C" getStablePtr(R1 "ptr") [];
1760     RET_N(sp);
1761 }
1762
1763 deRefStablePtrzh_fast
1764 {
1765     /* Args: R1 = the stable ptr */
1766     W_ r, sp;
1767     sp = R1;
1768     r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
1769     RET_P(r);
1770 }
1771
1772 /* -----------------------------------------------------------------------------
1773    Bytecode object primitives
1774    -------------------------------------------------------------------------  */
1775
1776 newBCOzh_fast
1777 {
1778     /* R1 = instrs
1779        R2 = literals
1780        R3 = ptrs
1781        R4 = itbls
1782        R5 = arity
1783        R6 = bitmap array
1784     */
1785     W_ bco, bitmap_arr, bytes, words;
1786
1787     bitmap_arr = R6;
1788     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1789     bytes = WDS(words);
1790
1791     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
1792
1793     bco = Hp - bytes + WDS(1);
1794     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1795
1796     StgBCO_instrs(bco)     = R1;
1797     StgBCO_literals(bco)   = R2;
1798     StgBCO_ptrs(bco)       = R3;
1799     StgBCO_itbls(bco)      = R4;
1800     StgBCO_arity(bco)      = HALF_W_(R5);
1801     StgBCO_size(bco)       = HALF_W_(words);
1802
1803     // Copy the arity/bitmap info into the BCO
1804     W_ i;
1805     i = 0;
1806 for:
1807     if (i < StgArrWords_words(bitmap_arr)) {
1808         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1809         i = i + 1;
1810         goto for;
1811     }
1812
1813     RET_P(bco);
1814 }
1815
1816
1817 mkApUpd0zh_fast
1818 {
1819     // R1 = the BCO# for the AP
1820     //
1821     W_ ap;
1822
1823     // This function is *only* used to wrap zero-arity BCOs in an
1824     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1825     // saturated and always points directly to a FUN or BCO.
1826     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1827            StgBCO_arity(R1) == HALF_W_(0));
1828
1829     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
1830     TICK_ALLOC_UP_THK(0, 0);
1831     CCCS_ALLOC(SIZEOF_StgAP);
1832
1833     ap = Hp - SIZEOF_StgAP + WDS(1);
1834     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1835
1836     StgAP_n_args(ap) = HALF_W_(0);
1837     StgAP_fun(ap) = R1;
1838
1839     RET_P(ap);
1840 }
1841
1842 /* -----------------------------------------------------------------------------
1843    Thread I/O blocking primitives
1844    -------------------------------------------------------------------------- */
1845
1846 /* Add a thread to the end of the blocked queue. (C-- version of the C
1847  * macro in Schedule.h).
1848  */
1849 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1850     ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);          \
1851     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1852       W_[blocked_queue_hd] = tso;                       \
1853     } else {                                            \
1854       StgTSO_link(W_[blocked_queue_tl]) = tso;          \
1855     }                                                   \
1856     W_[blocked_queue_tl] = tso;
1857
1858 waitReadzh_fast
1859 {
1860     /* args: R1 */
1861 #ifdef THREADED_RTS
1862     foreign "C" barf("waitRead# on threaded RTS");
1863 #else
1864
1865     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1866     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1867     StgTSO_block_info(CurrentTSO) = R1;
1868     // No locking - we're not going to use this interface in the
1869     // threaded RTS anyway.
1870     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1871     jump stg_block_noregs;
1872 #endif
1873 }
1874
1875 waitWritezh_fast
1876 {
1877     /* args: R1 */
1878 #ifdef THREADED_RTS
1879     foreign "C" barf("waitWrite# on threaded RTS");
1880 #else
1881
1882     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1883     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1884     StgTSO_block_info(CurrentTSO) = R1;
1885     // No locking - we're not going to use this interface in the
1886     // threaded RTS anyway.
1887     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1888     jump stg_block_noregs;
1889 #endif
1890 }
1891
1892
1893 STRING(stg_delayzh_malloc_str, "delayzh_fast")
1894 delayzh_fast
1895 {
1896 #ifdef mingw32_HOST_OS
1897     W_ ares;
1898     CInt reqID;
1899 #else
1900     W_ t, prev, target;
1901 #endif
1902
1903 #ifdef THREADED_RTS
1904     foreign "C" barf("delay# on threaded RTS");
1905 #else
1906
1907     /* args: R1 (microsecond delay amount) */
1908     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1909     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1910
1911 #ifdef mingw32_HOST_OS
1912
1913     /* could probably allocate this on the heap instead */
1914     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1915                                             stg_delayzh_malloc_str);
1916     reqID = foreign "C" addDelayRequest(R1);
1917     StgAsyncIOResult_reqID(ares)   = reqID;
1918     StgAsyncIOResult_len(ares)     = 0;
1919     StgAsyncIOResult_errCode(ares) = 0;
1920     StgTSO_block_info(CurrentTSO)  = ares;
1921
1922     /* Having all async-blocked threads reside on the blocked_queue
1923      * simplifies matters, so change the status to OnDoProc put the
1924      * delayed thread on the blocked_queue.
1925      */
1926     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1927     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1928     jump stg_block_async_void;
1929
1930 #else
1931
1932     W_ time;
1933     time = foreign "C" getourtimeofday();
1934     target = (R1 / (TICK_MILLISECS*1000)) + time;
1935     StgTSO_block_info(CurrentTSO) = target;
1936
1937     /* Insert the new thread in the sleeping queue. */
1938     prev = NULL;
1939     t = W_[sleeping_queue];
1940 while:
1941     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1942         prev = t;
1943         t = StgTSO_link(t);
1944         goto while;
1945     }
1946
1947     StgTSO_link(CurrentTSO) = t;
1948     if (prev == NULL) {
1949         W_[sleeping_queue] = CurrentTSO;
1950     } else {
1951         StgTSO_link(prev) = CurrentTSO;
1952     }
1953     jump stg_block_noregs;
1954 #endif
1955 #endif /* !THREADED_RTS */
1956 }
1957
1958
1959 #ifdef mingw32_HOST_OS
1960 STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
1961 asyncReadzh_fast
1962 {
1963     W_ ares;
1964     CInt reqID;
1965
1966 #ifdef THREADED_RTS
1967     foreign "C" barf("asyncRead# on threaded RTS");
1968 #else
1969
1970     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1971     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1972     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1973
1974     /* could probably allocate this on the heap instead */
1975     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1976                                             stg_asyncReadzh_malloc_str);
1977     reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr");
1978     StgAsyncIOResult_reqID(ares)   = reqID;
1979     StgAsyncIOResult_len(ares)     = 0;
1980     StgAsyncIOResult_errCode(ares) = 0;
1981     StgTSO_block_info(CurrentTSO)  = ares;
1982     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1983     jump stg_block_async;
1984 #endif
1985 }
1986
1987 STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
1988 asyncWritezh_fast
1989 {
1990     W_ ares;
1991     CInt reqID;
1992
1993 #ifdef THREADED_RTS
1994     foreign "C" barf("asyncWrite# on threaded RTS");
1995 #else
1996
1997     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1998     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1999     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
2000
2001     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2002                                             stg_asyncWritezh_malloc_str);
2003     reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr");
2004
2005     StgAsyncIOResult_reqID(ares)   = reqID;
2006     StgAsyncIOResult_len(ares)     = 0;
2007     StgAsyncIOResult_errCode(ares) = 0;
2008     StgTSO_block_info(CurrentTSO)  = ares;
2009     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2010     jump stg_block_async;
2011 #endif
2012 }
2013
2014 STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
2015 asyncDoProczh_fast
2016 {
2017     W_ ares;
2018     CInt reqID;
2019
2020 #ifdef THREADED_RTS
2021     foreign "C" barf("asyncDoProc# on threaded RTS");
2022 #else
2023
2024     /* args: R1 = proc, R2 = param */
2025     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2026     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
2027
2028     /* could probably allocate this on the heap instead */
2029     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2030                                             stg_asyncDoProczh_malloc_str);
2031     reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr");
2032     StgAsyncIOResult_reqID(ares)   = reqID;
2033     StgAsyncIOResult_len(ares)     = 0;
2034     StgAsyncIOResult_errCode(ares) = 0;
2035     StgTSO_block_info(CurrentTSO) = ares;
2036     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2037     jump stg_block_async;
2038 #endif
2039 }
2040 #endif
2041
2042 /* -----------------------------------------------------------------------------
2043   ** temporary **
2044
2045    classes CCallable and CReturnable don't really exist, but the
2046    compiler insists on generating dictionaries containing references
2047    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
2048    for these.  Some C compilers can't cope with zero-length static arrays,
2049    so we have to make these one element long.
2050   --------------------------------------------------------------------------- */
2051
2052 section "rodata" {
2053   GHC_ZCCCallable_static_info:   W_ 0;
2054 }
2055
2056 section "rodata" {
2057   GHC_ZCCReturnable_static_info: W_ 0;
2058 }