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(MyCapability() "ptr", 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       } else {
1272         foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1273       }
1274       if (r) {
1275         // Merge between siblings succeeded: commit it back to enclosing transaction
1276         // and then propagate the retry
1277         StgTSO_trec(CurrentTSO) = outer;
1278         Sp = Sp + SIZEOF_StgCatchRetryFrame;
1279         goto retry_pop_stack;
1280       } else {
1281         // Merge failed: we musn't propagate the retry.  Try both paths again.
1282         "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1283         StgCatchRetryFrame_first_code_trec(frame) = trec;
1284         StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
1285         StgTSO_trec(CurrentTSO) = trec;
1286         R1 = StgCatchRetryFrame_first_code(frame);
1287         Sp_adj(-1);
1288         jump RET_LBL(stg_ap_v);
1289       }
1290     }
1291   }
1292
1293   // We've reached the ATOMICALLY_FRAME: attempt to wait
1294   ASSERT(frame_type == ATOMICALLY_FRAME);
1295   ASSERT(outer == NO_TREC);
1296   r = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
1297   if (r) {
1298     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1299     StgAtomicallyFrame_waiting(frame) = 1 :: CInt; // true
1300     Sp = frame;
1301     // Fix up the stack in the unregisterised case: the return convention is different.
1302     IF_NOT_REG_R1(Sp_adj(-2);
1303                   Sp(1) = stg_NO_FINALIZER_closure;
1304                   Sp(0) = stg_ut_1_0_unreg_info;)
1305     R3 = trec; // passing to stmWaitUnblock()
1306     jump stg_block_stmwait;
1307   } else {
1308     // Transaction was not valid: retry immediately
1309     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1310     StgTSO_trec(CurrentTSO) = trec;
1311     R1 = StgAtomicallyFrame_code(frame);
1312     Sp = frame;
1313     Sp_adj(-1);
1314     jump RET_LBL(stg_ap_v);
1315   }
1316 }
1317
1318
1319 newTVarzh_fast
1320 {
1321   W_ tv;
1322   W_ new_value;
1323
1324   /* Args: R1 = initialisation value */
1325
1326   MAYBE_GC (R1_PTR, newTVarzh_fast);
1327   new_value = R1;
1328   "ptr" tv = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr");
1329   RET_P(tv);
1330 }
1331
1332
1333 readTVarzh_fast
1334 {
1335   W_ trec;
1336   W_ tvar;
1337   W_ result;
1338
1339   /* Args: R1 = TVar closure */
1340
1341   MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate
1342   trec = StgTSO_trec(CurrentTSO);
1343   tvar = R1;
1344   "ptr" result = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
1345
1346   RET_P(result);
1347 }
1348
1349
1350 writeTVarzh_fast
1351 {
1352   W_ trec;
1353   W_ tvar;
1354   W_ new_value;
1355
1356   /* Args: R1 = TVar closure */
1357   /*       R2 = New value    */
1358
1359   MAYBE_GC (R1_PTR & R2_PTR, writeTVarzh_fast); // Call to stmWriteTVar may allocate
1360   trec = StgTSO_trec(CurrentTSO);
1361   tvar = R1;
1362   new_value = R2;
1363   foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
1364
1365   jump %ENTRY_CODE(Sp(0));
1366 }
1367
1368
1369 /* -----------------------------------------------------------------------------
1370  * MVar primitives
1371  *
1372  * take & putMVar work as follows.  Firstly, an important invariant:
1373  *
1374  *    If the MVar is full, then the blocking queue contains only
1375  *    threads blocked on putMVar, and if the MVar is empty then the
1376  *    blocking queue contains only threads blocked on takeMVar.
1377  *
1378  * takeMvar:
1379  *    MVar empty : then add ourselves to the blocking queue
1380  *    MVar full  : remove the value from the MVar, and
1381  *                 blocking queue empty     : return
1382  *                 blocking queue non-empty : perform the first blocked putMVar
1383  *                                            from the queue, and wake up the
1384  *                                            thread (MVar is now full again)
1385  *
1386  * putMVar is just the dual of the above algorithm.
1387  *
1388  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1389  * the stack of the thread waiting to do the putMVar.  See
1390  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1391  * the stack layout, and the PerformPut and PerformTake macros below.
1392  *
1393  * It is important that a blocked take or put is woken up with the
1394  * take/put already performed, because otherwise there would be a
1395  * small window of vulnerability where the thread could receive an
1396  * exception and never perform its take or put, and we'd end up with a
1397  * deadlock.
1398  *
1399  * -------------------------------------------------------------------------- */
1400
1401 isEmptyMVarzh_fast
1402 {
1403     /* args: R1 = MVar closure */
1404
1405     if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
1406         RET_N(1);
1407     } else {
1408         RET_N(0);
1409     }
1410 }
1411
1412 newMVarzh_fast
1413 {
1414     /* args: none */
1415     W_ mvar;
1416
1417     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
1418
1419     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1420     SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
1421     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1422     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1423     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1424     RET_P(mvar);
1425 }
1426
1427
1428 /* If R1 isn't available, pass it on the stack */
1429 #ifdef REG_R1
1430 #define PerformTake(tso, value)                         \
1431     W_[StgTSO_sp(tso) + WDS(1)] = value;                \
1432     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
1433 #else
1434 #define PerformTake(tso, value)                                 \
1435     W_[StgTSO_sp(tso) + WDS(1)] = value;                        \
1436     W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
1437 #endif
1438
1439 #define PerformPut(tso,lval)                    \
1440     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);   \
1441     lval = W_[StgTSO_sp(tso) - WDS(1)];
1442
1443 takeMVarzh_fast
1444 {
1445     W_ mvar, val, info, tso;
1446
1447     /* args: R1 = MVar closure */
1448     mvar = R1;
1449
1450 #if defined(SMP)
1451     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1452 #else
1453     info = GET_INFO(mvar);
1454 #endif
1455
1456     /* If the MVar is empty, put ourselves on its blocking queue,
1457      * and wait until we're woken up.
1458      */
1459     if (info == stg_EMPTY_MVAR_info) {
1460         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1461             StgMVar_head(mvar) = CurrentTSO;
1462         } else {
1463             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1464         }
1465         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1466         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1467         StgTSO_block_info(CurrentTSO)  = mvar;
1468         StgMVar_tail(mvar) = CurrentTSO;
1469
1470         jump stg_block_takemvar;
1471   }
1472
1473   /* we got the value... */
1474   val = StgMVar_value(mvar);
1475
1476   if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
1477   {
1478       /* There are putMVar(s) waiting...
1479        * wake up the first thread on the queue
1480        */
1481       ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1482
1483       /* actually perform the putMVar for the thread that we just woke up */
1484       tso = StgMVar_head(mvar);
1485       PerformPut(tso,StgMVar_value(mvar));
1486
1487 #if defined(GRAN) || defined(PAR)
1488       /* ToDo: check 2nd arg (mvar) is right */
1489       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
1490       StgMVar_head(mvar) = tso;
1491 #else
1492       "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1493                                          StgMVar_head(mvar) "ptr") [];
1494       StgMVar_head(mvar) = tso;
1495 #endif
1496
1497       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1498           StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1499       }
1500
1501 #if defined(SMP)
1502       foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1503 #endif
1504       RET_P(val);
1505   }
1506   else
1507   {
1508       /* No further putMVars, MVar is now empty */
1509       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1510
1511 #if defined(SMP)
1512       foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1513 #else
1514       SET_INFO(mvar,stg_EMPTY_MVAR_info);
1515 #endif
1516
1517       RET_P(val);
1518   }
1519 }
1520
1521
1522 tryTakeMVarzh_fast
1523 {
1524     W_ mvar, val, info, tso;
1525
1526     /* args: R1 = MVar closure */
1527
1528     mvar = R1;
1529
1530 #if defined(SMP)
1531     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1532 #else
1533     info = GET_INFO(mvar);
1534 #endif
1535
1536     if (info == stg_EMPTY_MVAR_info) {
1537 #if defined(SMP)
1538         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1539 #endif
1540         /* HACK: we need a pointer to pass back,
1541          * so we abuse NO_FINALIZER_closure
1542          */
1543         RET_NP(0, stg_NO_FINALIZER_closure);
1544     }
1545
1546     /* we got the value... */
1547     val = StgMVar_value(mvar);
1548
1549     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1550
1551         /* There are putMVar(s) waiting...
1552          * wake up the first thread on the queue
1553          */
1554         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1555
1556         /* actually perform the putMVar for the thread that we just woke up */
1557         tso = StgMVar_head(mvar);
1558         PerformPut(tso,StgMVar_value(mvar));
1559
1560 #if defined(GRAN) || defined(PAR)
1561         /* ToDo: check 2nd arg (mvar) is right */
1562         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
1563         StgMVar_head(mvar) = tso;
1564 #else
1565         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1566                                            StgMVar_head(mvar) "ptr") [];
1567         StgMVar_head(mvar) = tso;
1568 #endif
1569
1570         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1571             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1572         }
1573 #if defined(SMP)
1574         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1575 #endif
1576     }
1577     else
1578     {
1579         /* No further putMVars, MVar is now empty */
1580         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1581 #if defined(SMP)
1582         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1583 #else
1584         SET_INFO(mvar,stg_EMPTY_MVAR_info);
1585 #endif
1586     }
1587
1588     RET_NP(1, val);
1589 }
1590
1591
1592 putMVarzh_fast
1593 {
1594     W_ mvar, info, tso;
1595
1596     /* args: R1 = MVar, R2 = value */
1597     mvar = R1;
1598
1599 #if defined(SMP)
1600     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1601 #else
1602     info = GET_INFO(mvar);
1603 #endif
1604
1605     if (info == stg_FULL_MVAR_info) {
1606         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1607             StgMVar_head(mvar) = CurrentTSO;
1608         } else {
1609             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1610         }
1611         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1612         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1613         StgTSO_block_info(CurrentTSO)  = mvar;
1614         StgMVar_tail(mvar) = CurrentTSO;
1615
1616         jump stg_block_putmvar;
1617     }
1618
1619     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1620
1621         /* There are takeMVar(s) waiting: wake up the first one
1622          */
1623         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1624
1625         /* actually perform the takeMVar */
1626         tso = StgMVar_head(mvar);
1627         PerformTake(tso, R2);
1628
1629 #if defined(GRAN) || defined(PAR)
1630         /* ToDo: check 2nd arg (mvar) is right */
1631         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1632         StgMVar_head(mvar) = tso;
1633 #else
1634         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1635         StgMVar_head(mvar) = tso;
1636 #endif
1637
1638         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1639             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1640         }
1641
1642 #if defined(SMP)
1643         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1644 #endif
1645         jump %ENTRY_CODE(Sp(0));
1646     }
1647     else
1648     {
1649         /* No further takes, the MVar is now full. */
1650         StgMVar_value(mvar) = R2;
1651
1652 #if defined(SMP)
1653         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1654 #else
1655         SET_INFO(mvar,stg_FULL_MVAR_info);
1656 #endif
1657         jump %ENTRY_CODE(Sp(0));
1658     }
1659
1660     /* ToDo: yield afterward for better communication performance? */
1661 }
1662
1663
1664 tryPutMVarzh_fast
1665 {
1666     W_ mvar, info, tso;
1667
1668     /* args: R1 = MVar, R2 = value */
1669     mvar = R1;
1670
1671 #if defined(SMP)
1672     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1673 #else
1674     info = GET_INFO(mvar);
1675 #endif
1676
1677     if (info == stg_FULL_MVAR_info) {
1678 #if defined(SMP)
1679         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1680 #endif
1681         RET_N(0);
1682     }
1683
1684     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1685
1686         /* There are takeMVar(s) waiting: wake up the first one
1687          */
1688         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1689
1690         /* actually perform the takeMVar */
1691         tso = StgMVar_head(mvar);
1692         PerformTake(tso, R2);
1693
1694 #if defined(GRAN) || defined(PAR)
1695         /* ToDo: check 2nd arg (mvar) is right */
1696         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1697         StgMVar_head(mvar) = tso;
1698 #else
1699         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1700         StgMVar_head(mvar) = tso;
1701 #endif
1702
1703         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1704             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1705         }
1706
1707 #if defined(SMP)
1708         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1709 #endif
1710         jump %ENTRY_CODE(Sp(0));
1711     }
1712     else
1713     {
1714         /* No further takes, the MVar is now full. */
1715         StgMVar_value(mvar) = R2;
1716
1717 #if defined(SMP)
1718         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1719 #else
1720         SET_INFO(mvar,stg_FULL_MVAR_info);
1721 #endif
1722         jump %ENTRY_CODE(Sp(0));
1723     }
1724
1725     /* ToDo: yield afterward for better communication performance? */
1726 }
1727
1728
1729 /* -----------------------------------------------------------------------------
1730    Stable pointer primitives
1731    -------------------------------------------------------------------------  */
1732
1733 makeStableNamezh_fast
1734 {
1735     W_ index, sn_obj;
1736
1737     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
1738
1739     index = foreign "C" lookupStableName(R1 "ptr") [];
1740
1741     /* Is there already a StableName for this heap object?
1742      *  stable_ptr_table is a pointer to an array of snEntry structs.
1743      */
1744     if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
1745         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1746         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1747         StgStableName_sn(sn_obj) = index;
1748         snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
1749     } else {
1750         sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
1751     }
1752
1753     RET_P(sn_obj);
1754 }
1755
1756
1757 makeStablePtrzh_fast
1758 {
1759     /* Args: R1 = a */
1760     W_ sp;
1761     MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1762     "ptr" sp = foreign "C" getStablePtr(R1 "ptr") [];
1763     RET_N(sp);
1764 }
1765
1766 deRefStablePtrzh_fast
1767 {
1768     /* Args: R1 = the stable ptr */
1769     W_ r, sp;
1770     sp = R1;
1771     r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
1772     RET_P(r);
1773 }
1774
1775 /* -----------------------------------------------------------------------------
1776    Bytecode object primitives
1777    -------------------------------------------------------------------------  */
1778
1779 newBCOzh_fast
1780 {
1781     /* R1 = instrs
1782        R2 = literals
1783        R3 = ptrs
1784        R4 = itbls
1785        R5 = arity
1786        R6 = bitmap array
1787     */
1788     W_ bco, bitmap_arr, bytes, words;
1789
1790     bitmap_arr = R6;
1791     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1792     bytes = WDS(words);
1793
1794     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
1795
1796     bco = Hp - bytes + WDS(1);
1797     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1798
1799     StgBCO_instrs(bco)     = R1;
1800     StgBCO_literals(bco)   = R2;
1801     StgBCO_ptrs(bco)       = R3;
1802     StgBCO_itbls(bco)      = R4;
1803     StgBCO_arity(bco)      = HALF_W_(R5);
1804     StgBCO_size(bco)       = HALF_W_(words);
1805
1806     // Copy the arity/bitmap info into the BCO
1807     W_ i;
1808     i = 0;
1809 for:
1810     if (i < StgArrWords_words(bitmap_arr)) {
1811         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1812         i = i + 1;
1813         goto for;
1814     }
1815
1816     RET_P(bco);
1817 }
1818
1819
1820 mkApUpd0zh_fast
1821 {
1822     // R1 = the BCO# for the AP
1823     //
1824     W_ ap;
1825
1826     // This function is *only* used to wrap zero-arity BCOs in an
1827     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1828     // saturated and always points directly to a FUN or BCO.
1829     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1830            StgBCO_arity(R1) == HALF_W_(0));
1831
1832     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
1833     TICK_ALLOC_UP_THK(0, 0);
1834     CCCS_ALLOC(SIZEOF_StgAP);
1835
1836     ap = Hp - SIZEOF_StgAP + WDS(1);
1837     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1838
1839     StgAP_n_args(ap) = HALF_W_(0);
1840     StgAP_fun(ap) = R1;
1841
1842     RET_P(ap);
1843 }
1844
1845 /* -----------------------------------------------------------------------------
1846    Thread I/O blocking primitives
1847    -------------------------------------------------------------------------- */
1848
1849 /* Add a thread to the end of the blocked queue. (C-- version of the C
1850  * macro in Schedule.h).
1851  */
1852 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1853     ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);          \
1854     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1855       W_[blocked_queue_hd] = tso;                       \
1856     } else {                                            \
1857       StgTSO_link(W_[blocked_queue_tl]) = tso;          \
1858     }                                                   \
1859     W_[blocked_queue_tl] = tso;
1860
1861 waitReadzh_fast
1862 {
1863     /* args: R1 */
1864 #ifdef THREADED_RTS
1865     foreign "C" barf("waitRead# on threaded RTS");
1866 #else
1867
1868     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1869     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1870     StgTSO_block_info(CurrentTSO) = R1;
1871     // No locking - we're not going to use this interface in the
1872     // threaded RTS anyway.
1873     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1874     jump stg_block_noregs;
1875 #endif
1876 }
1877
1878 waitWritezh_fast
1879 {
1880     /* args: R1 */
1881 #ifdef THREADED_RTS
1882     foreign "C" barf("waitWrite# on threaded RTS");
1883 #else
1884
1885     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1886     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1887     StgTSO_block_info(CurrentTSO) = R1;
1888     // No locking - we're not going to use this interface in the
1889     // threaded RTS anyway.
1890     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1891     jump stg_block_noregs;
1892 #endif
1893 }
1894
1895
1896 STRING(stg_delayzh_malloc_str, "delayzh_fast")
1897 delayzh_fast
1898 {
1899 #ifdef mingw32_HOST_OS
1900     W_ ares;
1901     CInt reqID;
1902 #else
1903     W_ t, prev, target;
1904 #endif
1905
1906 #ifdef THREADED_RTS
1907     foreign "C" barf("delay# on threaded RTS");
1908 #else
1909
1910     /* args: R1 (microsecond delay amount) */
1911     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1912     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1913
1914 #ifdef mingw32_HOST_OS
1915
1916     /* could probably allocate this on the heap instead */
1917     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1918                                             stg_delayzh_malloc_str);
1919     reqID = foreign "C" addDelayRequest(R1);
1920     StgAsyncIOResult_reqID(ares)   = reqID;
1921     StgAsyncIOResult_len(ares)     = 0;
1922     StgAsyncIOResult_errCode(ares) = 0;
1923     StgTSO_block_info(CurrentTSO)  = ares;
1924
1925     /* Having all async-blocked threads reside on the blocked_queue
1926      * simplifies matters, so change the status to OnDoProc put the
1927      * delayed thread on the blocked_queue.
1928      */
1929     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1930     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1931     jump stg_block_async_void;
1932
1933 #else
1934
1935     W_ time;
1936     time = foreign "C" getourtimeofday();
1937     target = (R1 / (TICK_MILLISECS*1000)) + time;
1938     StgTSO_block_info(CurrentTSO) = target;
1939
1940     /* Insert the new thread in the sleeping queue. */
1941     prev = NULL;
1942     t = W_[sleeping_queue];
1943 while:
1944     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1945         prev = t;
1946         t = StgTSO_link(t);
1947         goto while;
1948     }
1949
1950     StgTSO_link(CurrentTSO) = t;
1951     if (prev == NULL) {
1952         W_[sleeping_queue] = CurrentTSO;
1953     } else {
1954         StgTSO_link(prev) = CurrentTSO;
1955     }
1956     jump stg_block_noregs;
1957 #endif
1958 #endif /* !THREADED_RTS */
1959 }
1960
1961
1962 #ifdef mingw32_HOST_OS
1963 STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
1964 asyncReadzh_fast
1965 {
1966     W_ ares;
1967     CInt reqID;
1968
1969 #ifdef THREADED_RTS
1970     foreign "C" barf("asyncRead# on threaded RTS");
1971 #else
1972
1973     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1974     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1975     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1976
1977     /* could probably allocate this on the heap instead */
1978     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1979                                             stg_asyncReadzh_malloc_str);
1980     reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr");
1981     StgAsyncIOResult_reqID(ares)   = reqID;
1982     StgAsyncIOResult_len(ares)     = 0;
1983     StgAsyncIOResult_errCode(ares) = 0;
1984     StgTSO_block_info(CurrentTSO)  = ares;
1985     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1986     jump stg_block_async;
1987 #endif
1988 }
1989
1990 STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
1991 asyncWritezh_fast
1992 {
1993     W_ ares;
1994     CInt reqID;
1995
1996 #ifdef THREADED_RTS
1997     foreign "C" barf("asyncWrite# on threaded RTS");
1998 #else
1999
2000     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
2001     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2002     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
2003
2004     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2005                                             stg_asyncWritezh_malloc_str);
2006     reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr");
2007
2008     StgAsyncIOResult_reqID(ares)   = reqID;
2009     StgAsyncIOResult_len(ares)     = 0;
2010     StgAsyncIOResult_errCode(ares) = 0;
2011     StgTSO_block_info(CurrentTSO)  = ares;
2012     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2013     jump stg_block_async;
2014 #endif
2015 }
2016
2017 STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
2018 asyncDoProczh_fast
2019 {
2020     W_ ares;
2021     CInt reqID;
2022
2023 #ifdef THREADED_RTS
2024     foreign "C" barf("asyncDoProc# on threaded RTS");
2025 #else
2026
2027     /* args: R1 = proc, R2 = param */
2028     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2029     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
2030
2031     /* could probably allocate this on the heap instead */
2032     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2033                                             stg_asyncDoProczh_malloc_str);
2034     reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr");
2035     StgAsyncIOResult_reqID(ares)   = reqID;
2036     StgAsyncIOResult_len(ares)     = 0;
2037     StgAsyncIOResult_errCode(ares) = 0;
2038     StgTSO_block_info(CurrentTSO) = ares;
2039     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2040     jump stg_block_async;
2041 #endif
2042 }
2043 #endif
2044
2045 /* -----------------------------------------------------------------------------
2046   ** temporary **
2047
2048    classes CCallable and CReturnable don't really exist, but the
2049    compiler insists on generating dictionaries containing references
2050    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
2051    for these.  Some C compilers can't cope with zero-length static arrays,
2052    so we have to make these one element long.
2053   --------------------------------------------------------------------------- */
2054
2055 section "rodata" {
2056   GHC_ZCCCallable_static_info:   W_ 0;
2057 }
2058
2059 section "rodata" {
2060   GHC_ZCCReturnable_static_info: W_ 0;
2061 }