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