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 3
1025 #define ATOMICALLY_FRAME_WORDS  3
1026 #else
1027 #define ATOMICALLY_FRAME_BITMAP 0
1028 #define ATOMICALLY_FRAME_WORDS  1
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
1050   /* The TSO is not currently waiting: try to commit the transaction */
1051   valid = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr");
1052   if (valid) {
1053     /* Transaction was valid: commit succeeded */
1054     StgTSO_trec(CurrentTSO) = NO_TREC;
1055     Sp = Sp + SIZEOF_StgAtomicallyFrame;
1056     IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)
1057     jump %ENTRY_CODE(Sp(SP_OFF));
1058   } else {
1059     /* Transaction was not valid: try again */
1060     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
1061     StgTSO_trec(CurrentTSO) = trec;
1062     R1 = StgAtomicallyFrame_code(frame);
1063     Sp_adj(-1);
1064     jump RET_LBL(stg_ap_v);
1065   }
1066 }
1067
1068 INFO_TABLE_RET(stg_atomically_waiting_frame,
1069                ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP,
1070                ATOMICALLY_FRAME,
1071                stg_atomically_frame_0_ret,
1072                stg_atomically_frame_1_ret,
1073                stg_atomically_frame_2_ret,
1074                stg_atomically_frame_3_ret,
1075                stg_atomically_frame_4_ret,
1076                stg_atomically_frame_5_ret,
1077                stg_atomically_frame_6_ret,
1078                stg_atomically_frame_7_ret)
1079 {
1080   W_ frame, trec, valid;
1081   IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )
1082
1083   frame = Sp;
1084
1085   /* The TSO is currently waiting: should we stop waiting? */
1086   valid = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr");
1087   if (valid) {
1088     /* Previous attempt is still valid: no point trying again yet */
1089           IF_NOT_REG_R1(Sp_adj(-2);
1090                         Sp(1) = stg_NO_FINALIZER_closure;
1091                         Sp(0) = stg_ut_1_0_unreg_info;)
1092     jump stg_block_noregs;
1093   } else {
1094     /* Previous attempt is no longer valid: try again */
1095     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr");
1096     StgTSO_trec(CurrentTSO) = trec;
1097     StgHeader_info(frame) = stg_atomically_frame_info;
1098     R1 = StgAtomicallyFrame_code(frame);
1099     Sp_adj(-1);
1100     jump RET_LBL(stg_ap_v);
1101   }
1102 }
1103
1104 // STM catch frame --------------------------------------------------------------
1105
1106 #define CATCH_STM_FRAME_ENTRY_TEMPLATE(label,ret)          \
1107    label                                                   \
1108    {                                                       \
1109       IF_NOT_REG_R1(W_ rval;  rval = Sp(0);  Sp_adj(1); )  \
1110       Sp = Sp + SIZEOF_StgCatchSTMFrame;                   \
1111       IF_NOT_REG_R1(Sp_adj(-1); Sp(0) = rval;)             \
1112       jump ret;                                            \
1113    }
1114
1115 #ifdef REG_R1
1116 #define SP_OFF 0
1117 #else
1118 #define SP_OFF 1
1119 #endif
1120
1121 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_0_ret,%RET_VEC(Sp(SP_OFF),0))
1122 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_1_ret,%RET_VEC(Sp(SP_OFF),1))
1123 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_2_ret,%RET_VEC(Sp(SP_OFF),2))
1124 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_3_ret,%RET_VEC(Sp(SP_OFF),3))
1125 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_4_ret,%RET_VEC(Sp(SP_OFF),4))
1126 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_5_ret,%RET_VEC(Sp(SP_OFF),5))
1127 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_6_ret,%RET_VEC(Sp(SP_OFF),6))
1128 CATCH_STM_FRAME_ENTRY_TEMPLATE(stg_catch_stm_frame_7_ret,%RET_VEC(Sp(SP_OFF),7))
1129
1130 #if MAX_VECTORED_RTN > 8
1131 #error MAX_VECTORED_RTN has changed: please modify stg_catch_stm_frame too.
1132 #endif
1133
1134 #if defined(PROFILING)
1135 #define CATCH_STM_FRAME_BITMAP 3
1136 #define CATCH_STM_FRAME_WORDS  3
1137 #else
1138 #define CATCH_STM_FRAME_BITMAP 0
1139 #define CATCH_STM_FRAME_WORDS  1
1140 #endif
1141
1142 /* Catch frames are very similar to update frames, but when entering
1143  * one we just pop the frame off the stack and perform the correct
1144  * kind of return to the activation record underneath us on the stack.
1145  */
1146
1147 INFO_TABLE_RET(stg_catch_stm_frame,
1148                CATCH_STM_FRAME_WORDS, CATCH_STM_FRAME_BITMAP,
1149                CATCH_STM_FRAME,
1150                stg_catch_stm_frame_0_ret,
1151                stg_catch_stm_frame_1_ret,
1152                stg_catch_stm_frame_2_ret,
1153                stg_catch_stm_frame_3_ret,
1154                stg_catch_stm_frame_4_ret,
1155                stg_catch_stm_frame_5_ret,
1156                stg_catch_stm_frame_6_ret,
1157                stg_catch_stm_frame_7_ret)
1158 CATCH_STM_FRAME_ENTRY_TEMPLATE(,%ENTRY_CODE(Sp(SP_OFF)))
1159
1160
1161 // Primop definition ------------------------------------------------------------
1162
1163 atomicallyzh_fast
1164 {
1165   W_ frame;
1166   W_ old_trec;
1167   W_ new_trec;
1168
1169   // stmStartTransaction may allocate
1170   MAYBE_GC (R1_PTR, atomicallyzh_fast);
1171
1172   /* Args: R1 = m :: STM a */
1173   STK_CHK_GEN(SIZEOF_StgAtomicallyFrame + WDS(1), R1_PTR, atomicallyzh_fast);
1174
1175   /* Set up the atomically frame */
1176   Sp = Sp - SIZEOF_StgAtomicallyFrame;
1177   frame = Sp;
1178
1179   SET_HDR(frame,stg_atomically_frame_info, W_[CCCS]);
1180   StgAtomicallyFrame_code(frame) = R1;
1181
1182   /* Start the memory transcation */
1183   old_trec = StgTSO_trec(CurrentTSO);
1184   ASSERT(old_trec == NO_TREC);
1185   "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr");
1186   StgTSO_trec(CurrentTSO) = new_trec;
1187
1188   /* Apply R1 to the realworld token */
1189   Sp_adj(-1);
1190   jump RET_LBL(stg_ap_v);
1191 }
1192
1193
1194 catchSTMzh_fast
1195 {
1196   W_ frame;
1197
1198   /* Args: R1 :: STM a */
1199   /* Args: R2 :: Exception -> STM a */
1200   STK_CHK_GEN(SIZEOF_StgCatchSTMFrame + WDS(1), R1_PTR & R2_PTR, catchSTMzh_fast);
1201
1202   /* Set up the catch frame */
1203   Sp = Sp - SIZEOF_StgCatchSTMFrame;
1204   frame = Sp;
1205
1206   SET_HDR(frame, stg_catch_stm_frame_info, W_[CCCS]);
1207   StgCatchSTMFrame_handler(frame) = R2;
1208
1209   /* Apply R1 to the realworld token */
1210   Sp_adj(-1);
1211   jump RET_LBL(stg_ap_v);
1212 }
1213
1214
1215 catchRetryzh_fast
1216 {
1217   W_ frame;
1218   W_ new_trec;
1219   W_ trec;
1220
1221   // stmStartTransaction may allocate
1222   MAYBE_GC (R1_PTR & R2_PTR, catchRetryzh_fast);
1223
1224   /* Args: R1 :: STM a */
1225   /* Args: R2 :: STM a */
1226   STK_CHK_GEN(SIZEOF_StgCatchRetryFrame + WDS(1), R1_PTR & R2_PTR, catchRetryzh_fast);
1227
1228   /* Start a nested transaction within which to run the first code */
1229   trec = StgTSO_trec(CurrentTSO);
1230   "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr");
1231   StgTSO_trec(CurrentTSO) = new_trec;
1232
1233   /* Set up the catch-retry frame */
1234   Sp = Sp - SIZEOF_StgCatchRetryFrame;
1235   frame = Sp;
1236
1237   SET_HDR(frame, stg_catch_retry_frame_info, W_[CCCS]);
1238   StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
1239   StgCatchRetryFrame_first_code(frame) = R1;
1240   StgCatchRetryFrame_alt_code(frame) = R2;
1241   StgCatchRetryFrame_first_code_trec(frame) = new_trec;
1242
1243   /* Apply R1 to the realworld token */
1244   Sp_adj(-1);
1245   jump RET_LBL(stg_ap_v);
1246 }
1247
1248
1249 retryzh_fast
1250 {
1251   W_ frame_type;
1252   W_ frame;
1253   W_ trec;
1254   W_ outer;
1255   W_ r;
1256
1257   MAYBE_GC (NO_PTRS, retryzh_fast); // STM operations may allocate
1258
1259   // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
1260 retry_pop_stack:
1261   trec = StgTSO_trec(CurrentTSO);
1262   "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr");
1263   StgTSO_sp(CurrentTSO) = Sp;
1264   frame_type = foreign "C" findRetryFrameHelper(CurrentTSO "ptr");
1265   Sp = StgTSO_sp(CurrentTSO);
1266   frame = Sp;
1267
1268   if (frame_type == CATCH_RETRY_FRAME) {
1269     // The retry reaches a CATCH_RETRY_FRAME before the atomic frame
1270     ASSERT(outer != NO_TREC);
1271     if (!StgCatchRetryFrame_running_alt_code(frame)) {
1272       // Retry in the first code: try the alternative
1273       "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1274       StgTSO_trec(CurrentTSO) = trec;
1275       StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
1276       R1 = StgCatchRetryFrame_alt_code(frame);
1277       Sp_adj(-1);
1278       jump RET_LBL(stg_ap_v);
1279     } else {
1280       // Retry in the alternative code: propagate
1281       W_ other_trec;
1282       other_trec = StgCatchRetryFrame_first_code_trec(frame);
1283       r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", other_trec "ptr");
1284       if (r) {
1285         r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr");
1286       } else {
1287         foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr");
1288       }
1289       if (r) {
1290         // Merge between siblings succeeded: commit it back to enclosing transaction
1291         // and then propagate the retry
1292         StgTSO_trec(CurrentTSO) = outer;
1293         Sp = Sp + SIZEOF_StgCatchRetryFrame;
1294         goto retry_pop_stack;
1295       } else {
1296         // Merge failed: we musn't propagate the retry.  Try both paths again.
1297         "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1298         StgCatchRetryFrame_first_code_trec(frame) = trec;
1299         StgCatchRetryFrame_running_alt_code(frame) = 0 :: CInt; // false;
1300         StgTSO_trec(CurrentTSO) = trec;
1301         R1 = StgCatchRetryFrame_first_code(frame);
1302         Sp_adj(-1);
1303         jump RET_LBL(stg_ap_v);
1304       }
1305     }
1306   }
1307
1308   // We've reached the ATOMICALLY_FRAME: attempt to wait
1309   ASSERT(frame_type == ATOMICALLY_FRAME);
1310   ASSERT(outer == NO_TREC);
1311   r = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr");
1312   if (r) {
1313     // Transaction was valid: stmWait put us on the TVars' queues, we now block
1314     StgHeader_info(frame) = stg_atomically_waiting_frame_info;
1315     Sp = frame;
1316     // Fix up the stack in the unregisterised case: the return convention is different.
1317     IF_NOT_REG_R1(Sp_adj(-2);
1318                   Sp(1) = stg_NO_FINALIZER_closure;
1319                   Sp(0) = stg_ut_1_0_unreg_info;)
1320     R3 = trec; // passing to stmWaitUnblock()
1321     jump stg_block_stmwait;
1322   } else {
1323     // Transaction was not valid: retry immediately
1324     "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr");
1325     StgTSO_trec(CurrentTSO) = trec;
1326     R1 = StgAtomicallyFrame_code(frame);
1327     Sp = frame;
1328     Sp_adj(-1);
1329     jump RET_LBL(stg_ap_v);
1330   }
1331 }
1332
1333
1334 newTVarzh_fast
1335 {
1336   W_ tv;
1337   W_ new_value;
1338
1339   /* Args: R1 = initialisation value */
1340
1341   MAYBE_GC (R1_PTR, newTVarzh_fast);
1342   new_value = R1;
1343   "ptr" tv = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr");
1344   RET_P(tv);
1345 }
1346
1347
1348 readTVarzh_fast
1349 {
1350   W_ trec;
1351   W_ tvar;
1352   W_ result;
1353
1354   /* Args: R1 = TVar closure */
1355
1356   MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate
1357   trec = StgTSO_trec(CurrentTSO);
1358   tvar = R1;
1359   "ptr" result = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
1360
1361   RET_P(result);
1362 }
1363
1364
1365 writeTVarzh_fast
1366 {
1367   W_ trec;
1368   W_ tvar;
1369   W_ new_value;
1370
1371   /* Args: R1 = TVar closure */
1372   /*       R2 = New value    */
1373
1374   MAYBE_GC (R1_PTR & R2_PTR, writeTVarzh_fast); // Call to stmWriteTVar may allocate
1375   trec = StgTSO_trec(CurrentTSO);
1376   tvar = R1;
1377   new_value = R2;
1378   foreign "C" stmWriteTVar(MyCapability() "ptr", trec "ptr", tvar "ptr", new_value "ptr") [];
1379
1380   jump %ENTRY_CODE(Sp(0));
1381 }
1382
1383
1384 /* -----------------------------------------------------------------------------
1385  * MVar primitives
1386  *
1387  * take & putMVar work as follows.  Firstly, an important invariant:
1388  *
1389  *    If the MVar is full, then the blocking queue contains only
1390  *    threads blocked on putMVar, and if the MVar is empty then the
1391  *    blocking queue contains only threads blocked on takeMVar.
1392  *
1393  * takeMvar:
1394  *    MVar empty : then add ourselves to the blocking queue
1395  *    MVar full  : remove the value from the MVar, and
1396  *                 blocking queue empty     : return
1397  *                 blocking queue non-empty : perform the first blocked putMVar
1398  *                                            from the queue, and wake up the
1399  *                                            thread (MVar is now full again)
1400  *
1401  * putMVar is just the dual of the above algorithm.
1402  *
1403  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1404  * the stack of the thread waiting to do the putMVar.  See
1405  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1406  * the stack layout, and the PerformPut and PerformTake macros below.
1407  *
1408  * It is important that a blocked take or put is woken up with the
1409  * take/put already performed, because otherwise there would be a
1410  * small window of vulnerability where the thread could receive an
1411  * exception and never perform its take or put, and we'd end up with a
1412  * deadlock.
1413  *
1414  * -------------------------------------------------------------------------- */
1415
1416 isEmptyMVarzh_fast
1417 {
1418     /* args: R1 = MVar closure */
1419
1420     if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
1421         RET_N(1);
1422     } else {
1423         RET_N(0);
1424     }
1425 }
1426
1427 newMVarzh_fast
1428 {
1429     /* args: none */
1430     W_ mvar;
1431
1432     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
1433
1434     mvar = Hp - SIZEOF_StgMVar + WDS(1);
1435     SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
1436     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
1437     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
1438     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1439     RET_P(mvar);
1440 }
1441
1442
1443 /* If R1 isn't available, pass it on the stack */
1444 #ifdef REG_R1
1445 #define PerformTake(tso, value)                         \
1446     W_[StgTSO_sp(tso) + WDS(1)] = value;                \
1447     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
1448 #else
1449 #define PerformTake(tso, value)                                 \
1450     W_[StgTSO_sp(tso) + WDS(1)] = value;                        \
1451     W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
1452 #endif
1453
1454 #define PerformPut(tso,lval)                    \
1455     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);   \
1456     lval = W_[StgTSO_sp(tso) - WDS(1)];
1457
1458 takeMVarzh_fast
1459 {
1460     W_ mvar, val, info, tso;
1461
1462     /* args: R1 = MVar closure */
1463     mvar = R1;
1464
1465 #if defined(SMP)
1466     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1467 #else
1468     info = GET_INFO(mvar);
1469 #endif
1470
1471     /* If the MVar is empty, put ourselves on its blocking queue,
1472      * and wait until we're woken up.
1473      */
1474     if (info == stg_EMPTY_MVAR_info) {
1475         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1476             StgMVar_head(mvar) = CurrentTSO;
1477         } else {
1478             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1479         }
1480         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1481         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1482         StgTSO_block_info(CurrentTSO)  = mvar;
1483         StgMVar_tail(mvar) = CurrentTSO;
1484
1485         jump stg_block_takemvar;
1486   }
1487
1488   /* we got the value... */
1489   val = StgMVar_value(mvar);
1490
1491   if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
1492   {
1493       /* There are putMVar(s) waiting...
1494        * wake up the first thread on the queue
1495        */
1496       ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1497
1498       /* actually perform the putMVar for the thread that we just woke up */
1499       tso = StgMVar_head(mvar);
1500       PerformPut(tso,StgMVar_value(mvar));
1501
1502 #if defined(GRAN) || defined(PAR)
1503       /* ToDo: check 2nd arg (mvar) is right */
1504       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
1505       StgMVar_head(mvar) = tso;
1506 #else
1507       "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1508                                          StgMVar_head(mvar) "ptr") [];
1509       StgMVar_head(mvar) = tso;
1510 #endif
1511
1512       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1513           StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1514       }
1515
1516 #if defined(SMP)
1517       foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1518 #endif
1519       RET_P(val);
1520   }
1521   else
1522   {
1523       /* No further putMVars, MVar is now empty */
1524       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1525
1526 #if defined(SMP)
1527       foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1528 #else
1529       SET_INFO(mvar,stg_EMPTY_MVAR_info);
1530 #endif
1531
1532       RET_P(val);
1533   }
1534 }
1535
1536
1537 tryTakeMVarzh_fast
1538 {
1539     W_ mvar, val, info, tso;
1540
1541     /* args: R1 = MVar closure */
1542
1543     mvar = R1;
1544
1545 #if defined(SMP)
1546     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1547 #else
1548     info = GET_INFO(mvar);
1549 #endif
1550
1551     if (info == stg_EMPTY_MVAR_info) {
1552 #if defined(SMP)
1553         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1554 #endif
1555         /* HACK: we need a pointer to pass back,
1556          * so we abuse NO_FINALIZER_closure
1557          */
1558         RET_NP(0, stg_NO_FINALIZER_closure);
1559     }
1560
1561     /* we got the value... */
1562     val = StgMVar_value(mvar);
1563
1564     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1565
1566         /* There are putMVar(s) waiting...
1567          * wake up the first thread on the queue
1568          */
1569         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1570
1571         /* actually perform the putMVar for the thread that we just woke up */
1572         tso = StgMVar_head(mvar);
1573         PerformPut(tso,StgMVar_value(mvar));
1574
1575 #if defined(GRAN) || defined(PAR)
1576         /* ToDo: check 2nd arg (mvar) is right */
1577         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
1578         StgMVar_head(mvar) = tso;
1579 #else
1580         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
1581                                            StgMVar_head(mvar) "ptr") [];
1582         StgMVar_head(mvar) = tso;
1583 #endif
1584
1585         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1586             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1587         }
1588 #if defined(SMP)
1589         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1590 #endif
1591     }
1592     else
1593     {
1594         /* No further putMVars, MVar is now empty */
1595         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1596 #if defined(SMP)
1597         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1598 #else
1599         SET_INFO(mvar,stg_EMPTY_MVAR_info);
1600 #endif
1601     }
1602
1603     RET_NP(1, val);
1604 }
1605
1606
1607 putMVarzh_fast
1608 {
1609     W_ mvar, info, tso;
1610
1611     /* args: R1 = MVar, R2 = value */
1612     mvar = R1;
1613
1614 #if defined(SMP)
1615     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1616 #else
1617     info = GET_INFO(mvar);
1618 #endif
1619
1620     if (info == stg_FULL_MVAR_info) {
1621         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1622             StgMVar_head(mvar) = CurrentTSO;
1623         } else {
1624             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1625         }
1626         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1627         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1628         StgTSO_block_info(CurrentTSO)  = mvar;
1629         StgMVar_tail(mvar) = CurrentTSO;
1630
1631         jump stg_block_putmvar;
1632     }
1633
1634     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1635
1636         /* There are takeMVar(s) waiting: wake up the first one
1637          */
1638         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1639
1640         /* actually perform the takeMVar */
1641         tso = StgMVar_head(mvar);
1642         PerformTake(tso, R2);
1643
1644 #if defined(GRAN) || defined(PAR)
1645         /* ToDo: check 2nd arg (mvar) is right */
1646         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1647         StgMVar_head(mvar) = tso;
1648 #else
1649         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1650         StgMVar_head(mvar) = tso;
1651 #endif
1652
1653         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1654             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1655         }
1656
1657 #if defined(SMP)
1658         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1659 #endif
1660         jump %ENTRY_CODE(Sp(0));
1661     }
1662     else
1663     {
1664         /* No further takes, the MVar is now full. */
1665         StgMVar_value(mvar) = R2;
1666
1667 #if defined(SMP)
1668         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1669 #else
1670         SET_INFO(mvar,stg_FULL_MVAR_info);
1671 #endif
1672         jump %ENTRY_CODE(Sp(0));
1673     }
1674
1675     /* ToDo: yield afterward for better communication performance? */
1676 }
1677
1678
1679 tryPutMVarzh_fast
1680 {
1681     W_ mvar, info, tso;
1682
1683     /* args: R1 = MVar, R2 = value */
1684     mvar = R1;
1685
1686 #if defined(SMP)
1687     "ptr" info = foreign "C" lockClosure(mvar "ptr");
1688 #else
1689     info = GET_INFO(mvar);
1690 #endif
1691
1692     if (info == stg_FULL_MVAR_info) {
1693 #if defined(SMP)
1694         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1695 #endif
1696         RET_N(0);
1697     }
1698
1699     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1700
1701         /* There are takeMVar(s) waiting: wake up the first one
1702          */
1703         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1704
1705         /* actually perform the takeMVar */
1706         tso = StgMVar_head(mvar);
1707         PerformTake(tso, R2);
1708
1709 #if defined(GRAN) || defined(PAR)
1710         /* ToDo: check 2nd arg (mvar) is right */
1711         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
1712         StgMVar_head(mvar) = tso;
1713 #else
1714         "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
1715         StgMVar_head(mvar) = tso;
1716 #endif
1717
1718         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1719             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1720         }
1721
1722 #if defined(SMP)
1723         foreign "C" unlockClosure(mvar "ptr", stg_EMPTY_MVAR_info);
1724 #endif
1725         jump %ENTRY_CODE(Sp(0));
1726     }
1727     else
1728     {
1729         /* No further takes, the MVar is now full. */
1730         StgMVar_value(mvar) = R2;
1731
1732 #if defined(SMP)
1733         foreign "C" unlockClosure(mvar "ptr", stg_FULL_MVAR_info);
1734 #else
1735         SET_INFO(mvar,stg_FULL_MVAR_info);
1736 #endif
1737         jump %ENTRY_CODE(Sp(0));
1738     }
1739
1740     /* ToDo: yield afterward for better communication performance? */
1741 }
1742
1743
1744 /* -----------------------------------------------------------------------------
1745    Stable pointer primitives
1746    -------------------------------------------------------------------------  */
1747
1748 makeStableNamezh_fast
1749 {
1750     W_ index, sn_obj;
1751
1752     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
1753
1754     index = foreign "C" lookupStableName(R1 "ptr") [];
1755
1756     /* Is there already a StableName for this heap object?
1757      *  stable_ptr_table is a pointer to an array of snEntry structs.
1758      */
1759     if ( snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) == NULL ) {
1760         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1761         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1762         StgStableName_sn(sn_obj) = index;
1763         snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry) = sn_obj;
1764     } else {
1765         sn_obj = snEntry_sn_obj(W_[stable_ptr_table] + index*SIZEOF_snEntry);
1766     }
1767
1768     RET_P(sn_obj);
1769 }
1770
1771
1772 makeStablePtrzh_fast
1773 {
1774     /* Args: R1 = a */
1775     W_ sp;
1776     MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1777     "ptr" sp = foreign "C" getStablePtr(R1 "ptr") [];
1778     RET_N(sp);
1779 }
1780
1781 deRefStablePtrzh_fast
1782 {
1783     /* Args: R1 = the stable ptr */
1784     W_ r, sp;
1785     sp = R1;
1786     r = snEntry_addr(W_[stable_ptr_table] + sp*SIZEOF_snEntry);
1787     RET_P(r);
1788 }
1789
1790 /* -----------------------------------------------------------------------------
1791    Bytecode object primitives
1792    -------------------------------------------------------------------------  */
1793
1794 newBCOzh_fast
1795 {
1796     /* R1 = instrs
1797        R2 = literals
1798        R3 = ptrs
1799        R4 = itbls
1800        R5 = arity
1801        R6 = bitmap array
1802     */
1803     W_ bco, bitmap_arr, bytes, words;
1804
1805     bitmap_arr = R6;
1806     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1807     bytes = WDS(words);
1808
1809     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
1810
1811     bco = Hp - bytes + WDS(1);
1812     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1813
1814     StgBCO_instrs(bco)     = R1;
1815     StgBCO_literals(bco)   = R2;
1816     StgBCO_ptrs(bco)       = R3;
1817     StgBCO_itbls(bco)      = R4;
1818     StgBCO_arity(bco)      = HALF_W_(R5);
1819     StgBCO_size(bco)       = HALF_W_(words);
1820
1821     // Copy the arity/bitmap info into the BCO
1822     W_ i;
1823     i = 0;
1824 for:
1825     if (i < StgArrWords_words(bitmap_arr)) {
1826         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1827         i = i + 1;
1828         goto for;
1829     }
1830
1831     RET_P(bco);
1832 }
1833
1834
1835 mkApUpd0zh_fast
1836 {
1837     // R1 = the BCO# for the AP
1838     //
1839     W_ ap;
1840
1841     // This function is *only* used to wrap zero-arity BCOs in an
1842     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1843     // saturated and always points directly to a FUN or BCO.
1844     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1845            StgBCO_arity(R1) == HALF_W_(0));
1846
1847     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
1848     TICK_ALLOC_UP_THK(0, 0);
1849     CCCS_ALLOC(SIZEOF_StgAP);
1850
1851     ap = Hp - SIZEOF_StgAP + WDS(1);
1852     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1853
1854     StgAP_n_args(ap) = HALF_W_(0);
1855     StgAP_fun(ap) = R1;
1856
1857     RET_P(ap);
1858 }
1859
1860 /* -----------------------------------------------------------------------------
1861    Thread I/O blocking primitives
1862    -------------------------------------------------------------------------- */
1863
1864 /* Add a thread to the end of the blocked queue. (C-- version of the C
1865  * macro in Schedule.h).
1866  */
1867 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1868     ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);          \
1869     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1870       W_[blocked_queue_hd] = tso;                       \
1871     } else {                                            \
1872       StgTSO_link(W_[blocked_queue_tl]) = tso;          \
1873     }                                                   \
1874     W_[blocked_queue_tl] = tso;
1875
1876 waitReadzh_fast
1877 {
1878     /* args: R1 */
1879 #ifdef THREADED_RTS
1880     foreign "C" barf("waitRead# on threaded RTS");
1881 #else
1882
1883     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1884     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1885     StgTSO_block_info(CurrentTSO) = R1;
1886     // No locking - we're not going to use this interface in the
1887     // threaded RTS anyway.
1888     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1889     jump stg_block_noregs;
1890 #endif
1891 }
1892
1893 waitWritezh_fast
1894 {
1895     /* args: R1 */
1896 #ifdef THREADED_RTS
1897     foreign "C" barf("waitWrite# on threaded RTS");
1898 #else
1899
1900     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1901     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1902     StgTSO_block_info(CurrentTSO) = R1;
1903     // No locking - we're not going to use this interface in the
1904     // threaded RTS anyway.
1905     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1906     jump stg_block_noregs;
1907 #endif
1908 }
1909
1910
1911 STRING(stg_delayzh_malloc_str, "delayzh_fast")
1912 delayzh_fast
1913 {
1914 #ifdef mingw32_HOST_OS
1915     W_ ares;
1916     CInt reqID;
1917 #else
1918     W_ t, prev, target;
1919 #endif
1920
1921 #ifdef THREADED_RTS
1922     foreign "C" barf("delay# on threaded RTS");
1923 #else
1924
1925     /* args: R1 (microsecond delay amount) */
1926     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1927     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1928
1929 #ifdef mingw32_HOST_OS
1930
1931     /* could probably allocate this on the heap instead */
1932     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1933                                             stg_delayzh_malloc_str);
1934     reqID = foreign "C" addDelayRequest(R1);
1935     StgAsyncIOResult_reqID(ares)   = reqID;
1936     StgAsyncIOResult_len(ares)     = 0;
1937     StgAsyncIOResult_errCode(ares) = 0;
1938     StgTSO_block_info(CurrentTSO)  = ares;
1939
1940     /* Having all async-blocked threads reside on the blocked_queue
1941      * simplifies matters, so change the status to OnDoProc put the
1942      * delayed thread on the blocked_queue.
1943      */
1944     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1945     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1946     jump stg_block_async_void;
1947
1948 #else
1949
1950     W_ time;
1951     time = foreign "C" getourtimeofday();
1952     target = (R1 / (TICK_MILLISECS*1000)) + time;
1953     StgTSO_block_info(CurrentTSO) = target;
1954
1955     /* Insert the new thread in the sleeping queue. */
1956     prev = NULL;
1957     t = W_[sleeping_queue];
1958 while:
1959     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1960         prev = t;
1961         t = StgTSO_link(t);
1962         goto while;
1963     }
1964
1965     StgTSO_link(CurrentTSO) = t;
1966     if (prev == NULL) {
1967         W_[sleeping_queue] = CurrentTSO;
1968     } else {
1969         StgTSO_link(prev) = CurrentTSO;
1970     }
1971     jump stg_block_noregs;
1972 #endif
1973 #endif /* !THREADED_RTS */
1974 }
1975
1976
1977 #ifdef mingw32_HOST_OS
1978 STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
1979 asyncReadzh_fast
1980 {
1981     W_ ares;
1982     CInt reqID;
1983
1984 #ifdef THREADED_RTS
1985     foreign "C" barf("asyncRead# on threaded RTS");
1986 #else
1987
1988     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1989     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1990     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1991
1992     /* could probably allocate this on the heap instead */
1993     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1994                                             stg_asyncReadzh_malloc_str);
1995     reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr");
1996     StgAsyncIOResult_reqID(ares)   = reqID;
1997     StgAsyncIOResult_len(ares)     = 0;
1998     StgAsyncIOResult_errCode(ares) = 0;
1999     StgTSO_block_info(CurrentTSO)  = ares;
2000     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2001     jump stg_block_async;
2002 #endif
2003 }
2004
2005 STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
2006 asyncWritezh_fast
2007 {
2008     W_ ares;
2009     CInt reqID;
2010
2011 #ifdef THREADED_RTS
2012     foreign "C" barf("asyncWrite# on threaded RTS");
2013 #else
2014
2015     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
2016     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2017     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
2018
2019     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2020                                             stg_asyncWritezh_malloc_str);
2021     reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr");
2022
2023     StgAsyncIOResult_reqID(ares)   = reqID;
2024     StgAsyncIOResult_len(ares)     = 0;
2025     StgAsyncIOResult_errCode(ares) = 0;
2026     StgTSO_block_info(CurrentTSO)  = ares;
2027     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2028     jump stg_block_async;
2029 #endif
2030 }
2031
2032 STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
2033 asyncDoProczh_fast
2034 {
2035     W_ ares;
2036     CInt reqID;
2037
2038 #ifdef THREADED_RTS
2039     foreign "C" barf("asyncDoProc# on threaded RTS");
2040 #else
2041
2042     /* args: R1 = proc, R2 = param */
2043     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
2044     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
2045
2046     /* could probably allocate this on the heap instead */
2047     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
2048                                             stg_asyncDoProczh_malloc_str);
2049     reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr");
2050     StgAsyncIOResult_reqID(ares)   = reqID;
2051     StgAsyncIOResult_len(ares)     = 0;
2052     StgAsyncIOResult_errCode(ares) = 0;
2053     StgTSO_block_info(CurrentTSO) = ares;
2054     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
2055     jump stg_block_async;
2056 #endif
2057 }
2058 #endif
2059
2060 /* -----------------------------------------------------------------------------
2061   ** temporary **
2062
2063    classes CCallable and CReturnable don't really exist, but the
2064    compiler insists on generating dictionaries containing references
2065    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
2066    for these.  Some C compilers can't cope with zero-length static arrays,
2067    so we have to make these one element long.
2068   --------------------------------------------------------------------------- */
2069
2070 section "rodata" {
2071   GHC_ZCCCallable_static_info:   W_ 0;
2072 }
2073
2074 section "rodata" {
2075   GHC_ZCCReturnable_static_info: W_ 0;
2076 }