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   SET_INFO(R1,stg_MUT_ARR_PTRS_info);
 122
 123   // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST
 124   //
 125   // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN
 126   // normally doesn't.  However, when we freeze a MUT_ARR_PTRS, we leave
 127   // it on the mutable list for the GC to remove (removing something from
 128   // the mutable list is not easy, because the mut_list is only singly-linked).
 129   //
 130   // So, when we thaw a MUT_ARR_PTRS_FROZEN, we must cope with two cases:
 131   // either it is on a mut_list, or it isn't.  We adopt the convention that
 132   // the mut_link field is NULL if it isn't on a mut_list, and the GC
 133   // maintains this invariant.
 134   //
 135   if (StgMutClosure_mut_link(R1) == NULL) {
 136         foreign "C" recordMutable(R1 "ptr");
 137   }
 138
 139   RET_P(R1);
 140 }
 141
 142 /* -----------------------------------------------------------------------------
 143    MutVar primitives
 144    -------------------------------------------------------------------------- */
 145
 146 newMutVarzh_fast
 147 {
 148     W_ mv;
 149     /* Args: R1 = initialisation value */
 150
 151     ALLOC_PRIM( SIZEOF_StgMutVar, R1_PTR, newMutVarzh_fast);
 152
 153     mv = Hp - SIZEOF_StgMutVar + WDS(1);
 154     SET_HDR(mv,stg_MUT_VAR_info,W_[CCCS]);
 155     StgMutVar_var(mv) = R1;
 156
 157     RET_P(mv);
 158 }
 159
 160 atomicModifyMutVarzh_fast
 161 {
 162     W_ mv, z, x, y, r;
 163     /* Args: R1 :: MutVar#,  R2 :: a -> (a,b) */
 164
 165     /* If x is the current contents of the MutVar#, then
 166        We want to make the new contents point to
 167
 168          (sel_0 (f x))
 169
 170        and the return value is
 171
 172          (sel_1 (f x))
 173
 174         obviously we can share (f x).
 175
 176          z = [stg_ap_2 f x]  (max (HS + 2) MIN_UPD_SIZE)
 177          y = [stg_sel_0 z]   (max (HS + 1) MIN_UPD_SIZE)
 178          r = [stg_sel_1 z]   (max (HS + 1) MIN_UPD_SIZE)
 179     */
 180
 181 #if MIN_UPD_SIZE > 1
 182 #define THUNK_1_SIZE (SIZEOF_StgHeader + WDS(MIN_UPD_SIZE))
 183 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),WDS(MIN_UPD_SIZE-1))
 184 #else
 185 #define THUNK_1_SIZE (SIZEOF_StgHeader + WDS(1))
 186 #define TICK_ALLOC_THUNK_1() TICK_ALLOC_UP_THK(WDS(1),0)
 187 #endif
 188
 189 #if MIN_UPD_SIZE > 2
 190 #define THUNK_2_SIZE (SIZEOF_StgHeader + WDS(MIN_UPD_SIZE))
 191 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),WDS(MIN_UPD_SIZE-2))
 192 #else
 193 #define THUNK_2_SIZE (SIZEOF_StgHeader + WDS(2))
 194 #define TICK_ALLOC_THUNK_2() TICK_ALLOC_UP_THK(WDS(2),0)
 195 #endif
 196
 197 #define SIZE (THUNK_2_SIZE + THUNK_1_SIZE + THUNK_1_SIZE)
 198
 199    HP_CHK_GEN_TICKY(SIZE, R1_PTR & R2_PTR, atomicModifyMutVarzh_fast);
 200
 201    x = StgMutVar_var(R1);
 202
 203    TICK_ALLOC_THUNK_2();
 204    CCCS_ALLOC(THUNK_2_SIZE);
 205    z = Hp - THUNK_2_SIZE + WDS(1);
 206    SET_HDR(z, stg_ap_2_upd_info, W_[CCCS]);
 207    LDV_RECORD_CREATE(z);
 208    StgClosure_payload(z,0) = R2;
 209    StgClosure_payload(z,1) = x;
 210
 211    TICK_ALLOC_THUNK_1();
 212    CCCS_ALLOC(THUNK_1_SIZE);
 213    y = z - THUNK_1_SIZE;
 214    SET_HDR(y, stg_sel_0_upd_info, W_[CCCS]);
 215    LDV_RECORD_CREATE(y);
 216    StgClosure_payload(y,0) = z;
 217
 218    StgMutVar_var(R1) = y;
 219
 220    TICK_ALLOC_THUNK_1();
 221    CCCS_ALLOC(THUNK_1_SIZE);
 222    r = y - THUNK_1_SIZE;
 223    SET_HDR(r, stg_sel_1_upd_info, W_[CCCS]);
 224    LDV_RECORD_CREATE(r);
 225    StgClosure_payload(r,0) = z;
 226
 227    RET_P(r);
 228 }
 229
 230 /* -----------------------------------------------------------------------------
 231    Foreign Object Primitives
 232    -------------------------------------------------------------------------- */
 233
 234 mkForeignObjzh_fast
 235 {
 236   /* R1 = ptr to foreign object,
 237   */
 238   W_ result;
 239
 240   ALLOC_PRIM( SIZEOF_StgForeignObj, NO_PTRS, mkForeignObjzh_fast);
 241
 242   result = Hp - SIZEOF_StgForeignObj + WDS(1);
 243   SET_HDR(result,stg_FOREIGN_info,W_[CCCS]);
 244   StgForeignObj_data(result) = R1;
 245
 246   /* returns (# s#, ForeignObj# #) */
 247   RET_P(result);
 248 }
 249
 250 /* -----------------------------------------------------------------------------
 251    Weak Pointer Primitives
 252    -------------------------------------------------------------------------- */
 253
 254 STRING(stg_weak_msg,"New weak pointer at %p\n")
 255
 256 mkWeakzh_fast
 257 {
 258   /* R1 = key
 259      R2 = value
 260      R3 = finalizer (or NULL)
 261   */
 262   W_ w;
 263
 264   if (R3 == NULL) {
 265     R3 = stg_NO_FINALIZER_closure;
 266   }
 267
 268   ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, mkWeakzh_fast );
 269
 270   w = Hp - SIZEOF_StgWeak + WDS(1);
 271   SET_HDR(w, stg_WEAK_info, W_[CCCS]);
 272
 273   StgWeak_key(w)       = R1;
 274   StgWeak_value(w)     = R2;
 275   StgWeak_finalizer(w) = R3;
 276
 277   StgWeak_link(w)       = W_[weak_ptr_list];
 278   W_[weak_ptr_list]     = w;
 279
 280   IF_DEBUG(weak, foreign "C" fprintf(stderr,stg_weak_msg,w));
 281
 282   RET_P(w);
 283 }
 284
 285
 286 finalizzeWeakzh_fast
 287 {
 288   /* R1 = weak ptr
 289    */
 290   W_ w, f;
 291
 292   w = R1;
 293
 294   // already dead?
 295   if (GET_INFO(w) == stg_DEAD_WEAK_info) {
 296       RET_NP(0,stg_NO_FINALIZER_closure);
 297   }
 298
 299   // kill it
 300 #ifdef PROFILING
 301   // @LDV profiling
 302   // A weak pointer is inherently used, so we do not need to call
 303   // LDV_recordDead_FILL_SLOP_DYNAMIC():
 304   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
 305   // or, LDV_recordDead():
 306   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
 307   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
 308   // large as weak pointers, so there is no need to fill the slop, either.
 309   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
 310 #endif
 311
 312   //
 313   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
 314   //
 315   SET_INFO(w,stg_DEAD_WEAK_info);
 316   LDV_RECORD_CREATE(w);
 317
 318   f = StgWeak_finalizer(w);
 319   StgDeadWeak_link(w) = StgWeak_link(w);
 320
 321   /* return the finalizer */
 322   if (f == stg_NO_FINALIZER_closure) {
 323       RET_NP(0,stg_NO_FINALIZER_closure);
 324   } else {
 325       RET_NP(1,f);
 326   }
 327 }
 328
 329 deRefWeakzh_fast
 330 {
 331   /* R1 = weak ptr */
 332   W_ w, code, val;
 333
 334   w = R1;
 335   if (GET_INFO(w) == stg_WEAK_info) {
 336     code = 1;
 337     val = StgWeak_value(w);
 338   } else {
 339     code = 0;
 340     val = w;
 341   }
 342   RET_NP(code,val);
 343 }
 344
 345 /* -----------------------------------------------------------------------------
 346    Arbitrary-precision Integer operations.
 347
 348    There are some assumptions in this code that mp_limb_t == W_.  This is
 349    the case for all the platforms that GHC supports, currently.
 350    -------------------------------------------------------------------------- */
 351
 352 int2Integerzh_fast
 353 {
 354    /* arguments: R1 = Int# */
 355
 356    W_ val, s, p;        /* to avoid aliasing */
 357
 358    val = R1;
 359    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, int2Integerzh_fast );
 360
 361    p = Hp - SIZEOF_StgArrWords;
 362    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 363    StgArrWords_words(p) = 1;
 364
 365    /* mpz_set_si is inlined here, makes things simpler */
 366    if (%lt(val,0)) {
 367         s  = -1;
 368         Hp(0) = -val;
 369    } else {
 370      if (%gt(val,0)) {
 371         s = 1;
 372         Hp(0) = val;
 373      } else {
 374         s = 0;
 375      }
 376   }
 377
 378    /* returns (# size  :: Int#,
 379                  data  :: ByteArray#
 380                #)
 381    */
 382    RET_NP(s,p);
 383 }
 384
 385 word2Integerzh_fast
 386 {
 387    /* arguments: R1 = Word# */
 388
 389    W_ val, s, p;        /* to avoid aliasing */
 390
 391    val = R1;
 392
 393    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, word2Integerzh_fast);
 394
 395    p = Hp - SIZEOF_StgArrWords;
 396    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 397    StgArrWords_words(p) = 1;
 398
 399    if (val != 0) {
 400         s = 1;
 401         W_[Hp] = val;
 402    } else {
 403         s = 0;
 404    }
 405
 406    /* returns (# size  :: Int#,
 407                  data  :: ByteArray# #)
 408    */
 409    RET_NP(s,p);
 410 }
 411
 412
 413 /*
 414  * 'long long' primops for converting to/from Integers.
 415  */
 416
 417 #ifdef SUPPORT_LONG_LONGS
 418
 419 int64ToIntegerzh_fast
 420 {
 421    /* arguments: L1 = Int64# */
 422
 423    L_ val;
 424    W_ hi, s, neg, words_needed, p;
 425
 426    val = L1;
 427    neg = 0;
 428
 429    if ( %ge(val,0x100000000::L_) || %le(val,-0x100000000::L_) )  {
 430        words_needed = 2;
 431    } else {
 432        // minimum is one word
 433        words_needed = 1;
 434    }
 435
 436    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
 437                NO_PTRS, int64ToIntegerzh_fast );
 438
 439    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
 440    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 441    StgArrWords_words(p) = words_needed;
 442
 443    if ( %lt(val,0::L_) ) {
 444      neg = 1;
 445      val = -val;
 446    }
 447
 448    hi = TO_W_(val >> 32);
 449
 450    if ( words_needed == 2 )  {
 451       s = 2;
 452       Hp(-1) = TO_W_(val);
 453       Hp(0) = hi;
 454    } else {
 455        if ( val != 0::L_ ) {
 456            s = 1;
 457            Hp(0) = TO_W_(val);
 458        } else /* val==0 */  {
 459            s = 0;
 460        }
 461    }
 462    if ( neg != 0 ) {
 463         s = -s;
 464    }
 465
 466    /* returns (# size  :: Int#,
 467                  data  :: ByteArray# #)
 468    */
 469    RET_NP(s,p);
 470 }
 471
 472 word64ToIntegerzh_fast
 473 {
 474    /* arguments: L1 = Word64# */
 475
 476    L_ val;
 477    W_ hi, s, words_needed, p;
 478
 479    val = L1;
 480    if ( val >= 0x100000000::L_ ) {
 481       words_needed = 2;
 482    } else {
 483       words_needed = 1;
 484    }
 485
 486    ALLOC_PRIM( SIZEOF_StgArrWords + WDS(words_needed),
 487                NO_PTRS, word64ToIntegerzh_fast );
 488
 489    p = Hp - SIZEOF_StgArrWords - WDS(words_needed) + WDS(1);
 490    SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 491    StgArrWords_words(p) = words_needed;
 492
 493    hi = TO_W_(val >> 32);
 494    if ( val >= 0x100000000::L_ ) {
 495      s = 2;
 496      Hp(-1) = TO_W_(val);
 497      Hp(0)  = hi;
 498    } else {
 499       if ( val != 0::L_ ) {
 500         s = 1;
 501         Hp(0) = TO_W_(val);
 502      } else /* val==0 */  {
 503       s = 0;
 504      }
 505   }
 506
 507    /* returns (# size  :: Int#,
 508                  data  :: ByteArray# #)
 509    */
 510    RET_NP(s,p);
 511 }
 512
 513
 514 #endif /* SUPPORT_LONG_LONGS */
 515
 516 /* ToDo: this is shockingly inefficient */
 517
 518 section "bss" {
 519   mp_tmp1:
 520     bits8 [SIZEOF_MP_INT];
 521 }
 522
 523 section "bss" {
 524   mp_tmp2:
 525     bits8 [SIZEOF_MP_INT];
 526 }
 527
 528 section "bss" {
 529   result1:
 530     bits8 [SIZEOF_MP_INT];
 531 }
 532
 533 section "bss" {
 534   result2:
 535     bits8 [SIZEOF_MP_INT];
 536 }
 537
 538 #define GMP_TAKE2_RET1(name,mp_fun)                     \
 539 name                                                    \
 540 {                                                       \
 541   W_ s1, s2, d1, d2;                                    \
 542                                                         \
 543   /* call doYouWantToGC() */                            \
 544   MAYBE_GC(R2_PTR & R4_PTR, name);                      \
 545                                                         \
 546   s1 = R1;                                              \
 547   d1 = R2;                                              \
 548   s2 = R3;                                              \
 549   d2 = R4;                                              \
 550                                                         \
 551   MP_INT__mp_alloc(mp_tmp1) = StgArrWords_words(d1);    \
 552   MP_INT__mp_size(mp_tmp1)  = (s1);                     \
 553   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);         \
 554   MP_INT__mp_alloc(mp_tmp2) = StgArrWords_words(d2);    \
 555   MP_INT__mp_size(mp_tmp2)  = (s2);                     \
 556   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);         \
 557                                                         \
 558   foreign "C" mpz_init(result1);                        \
 559                                                         \
 560   /* Perform the operation */                           \
 561   foreign "C" mp_fun(result1,mp_tmp1,mp_tmp2);          \
 562                                                         \
 563   RET_NP(MP_INT__mp_size(result1),                      \
 564          MP_INT__mp_d(result1) - SIZEOF_StgArrWords);   \
 565 }
 566
 567 #define GMP_TAKE1_RET1(name,mp_fun)                             \
 568 name                                                            \
 569 {                                                               \
 570   W_ s1, d1;                                                    \
 571                                                                 \
 572   /* call doYouWantToGC() */                                    \
 573   MAYBE_GC(R2_PTR, name);                                       \
 574                                                                 \
 575   d1 = R2;                                                      \
 576   s1 = R1;                                                      \
 577                                                                 \
 578   MP_INT__mp_alloc(mp_tmp1)     = StgArrWords_words(d1);        \
 579   MP_INT__mp_size(mp_tmp1)      = (s1);                         \
 580   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);             \
 581                                                                 \
 582   foreign "C" mpz_init(result1);                                \
 583                                                                 \
 584   /* Perform the operation */                                   \
 585   foreign "C" mp_fun(result1,mp_tmp1);                          \
 586                                                                 \
 587   RET_NP(MP_INT__mp_size(result1),                              \
 588          MP_INT__mp_d(result1) - SIZEOF_StgArrWords);           \
 589 }
 590
 591 #define GMP_TAKE2_RET2(name,mp_fun)                             \
 592 name                                                            \
 593 {                                                               \
 594   W_ s1, s2, d1, d2;                                            \
 595                                                                 \
 596   /* call doYouWantToGC() */                                    \
 597   MAYBE_GC(R2_PTR & R4_PTR, name);                              \
 598                                                                 \
 599   s1 = R1;                                                      \
 600   d1 = R2;                                                      \
 601   s2 = R3;                                                      \
 602   d2 = R4;                                                      \
 603                                                                 \
 604   MP_INT__mp_alloc(mp_tmp1)     = StgArrWords_words(d1);        \
 605   MP_INT__mp_size(mp_tmp1)      = (s1);                         \
 606   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);             \
 607   MP_INT__mp_alloc(mp_tmp2)     = StgArrWords_words(d2);        \
 608   MP_INT__mp_size(mp_tmp2)      = (s2);                         \
 609   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);             \
 610                                                                 \
 611   foreign "C" mpz_init(result1);                                \
 612   foreign "C" mpz_init(result2);                                \
 613                                                                 \
 614   /* Perform the operation */                                   \
 615   foreign "C" mp_fun(result1,result2,mp_tmp1,mp_tmp2);          \
 616                                                                 \
 617   RET_NPNP(MP_INT__mp_size(result1),                            \
 618            MP_INT__mp_d(result1) - SIZEOF_StgArrWords,          \
 619            MP_INT__mp_size(result2),                            \
 620            MP_INT__mp_d(result2) - SIZEOF_StgArrWords);         \
 621 }
 622
 623 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add)
 624 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub)
 625 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul)
 626 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd)
 627 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q)
 628 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r)
 629 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact)
 630 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and)
 631 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior)
 632 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor)
 633 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com)
 634
 635 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr)
 636 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr)
 637
 638 section "bss" {
 639   aa:  W_; // NB. aa is really an mp_limb_t
 640 }
 641
 642 gcdIntzh_fast
 643 {
 644     /* R1 = the first Int#; R2 = the second Int# */
 645     W_ r;
 646
 647     W_[aa] = R1;
 648     r = foreign "C" mpn_gcd_1(aa, 1, R2);
 649
 650     R1 = r;
 651     /* Result parked in R1, return via info-pointer at TOS */
 652     jump %ENTRY_CODE(Sp(0));
 653 }
 654
 655
 656 gcdIntegerIntzh_fast
 657 {
 658     /* R1 = s1; R2 = d1; R3 = the int */
 659     R1 = foreign "C" mpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3);
 660
 661     /* Result parked in R1, return via info-pointer at TOS */
 662     jump %ENTRY_CODE(Sp(0));
 663 }
 664
 665
 666 cmpIntegerIntzh_fast
 667 {
 668     /* R1 = s1; R2 = d1; R3 = the int */
 669     W_ usize, vsize, v_digit, u_digit;
 670
 671     usize = R1;
 672     vsize = 0;
 673     v_digit = R3;
 674
 675     // paraphrased from mpz_cmp_si() in the GMP sources
 676     if (%gt(v_digit,0)) {
 677         vsize = 1;
 678     } else {
 679         if (%lt(v_digit,0)) {
 680             vsize = -1;
 681             v_digit = -v_digit;
 682         }
 683     }
 684
 685     if (usize != vsize) {
 686         R1 = usize - vsize;
 687         jump %ENTRY_CODE(Sp(0));
 688     }
 689
 690     if (usize == 0) {
 691         R1 = 0;
 692         jump %ENTRY_CODE(Sp(0));
 693     }
 694
 695     u_digit = W_[BYTE_ARR_CTS(R2)];
 696
 697     if (u_digit == v_digit) {
 698         R1 = 0;
 699         jump %ENTRY_CODE(Sp(0));
 700     }
 701
 702     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
 703         R1 = usize;
 704     } else {
 705         R1 = -usize;
 706     }
 707
 708     jump %ENTRY_CODE(Sp(0));
 709 }
 710
 711 cmpIntegerzh_fast
 712 {
 713     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
 714     W_ usize, vsize, size, up, vp;
 715     CInt cmp;
 716
 717     // paraphrased from mpz_cmp() in the GMP sources
 718     usize = R1;
 719     vsize = R3;
 720
 721     if (usize != vsize) {
 722         R1 = usize - vsize;
 723         jump %ENTRY_CODE(Sp(0));
 724     }
 725
 726     if (usize == 0) {
 727         R1 = 0;
 728         jump %ENTRY_CODE(Sp(0));
 729     }
 730
 731     if (%lt(usize,0)) { // NB. not <, which is unsigned
 732         size = -usize;
 733     } else {
 734         size = usize;
 735     }
 736
 737     up = BYTE_ARR_CTS(R2);
 738     vp = BYTE_ARR_CTS(R4);
 739
 740     cmp = foreign "C" mpn_cmp(up "ptr", vp "ptr", size);
 741
 742     if (cmp == 0) {
 743         R1 = 0;
 744         jump %ENTRY_CODE(Sp(0));
 745     }
 746
 747     if (%lt(cmp,0) == %lt(usize,0)) {
 748         R1 = 1;
 749     } else {
 750         R1 = (-1);
 751     }
 752     /* Result parked in R1, return via info-pointer at TOS */
 753     jump %ENTRY_CODE(Sp(0));
 754 }
 755
 756 integer2Intzh_fast
 757 {
 758     /* R1 = s; R2 = d */
 759     W_ r, s;
 760
 761     s = R1;
 762     if (s == 0) {
 763         r = 0;
 764     } else {
 765         r = W_[R2 + SIZEOF_StgArrWords];
 766         if (%lt(s,0)) {
 767             r = -r;
 768         }
 769     }
 770     /* Result parked in R1, return via info-pointer at TOS */
 771     R1 = r;
 772     jump %ENTRY_CODE(Sp(0));
 773 }
 774
 775 integer2Wordzh_fast
 776 {
 777   /* R1 = s; R2 = d */
 778   W_ r, s;
 779
 780   s = R1;
 781   if (s == 0) {
 782     r = 0;
 783   } else {
 784     r = W_[R2 + SIZEOF_StgArrWords];
 785     if (%lt(s,0)) {
 786         r = -r;
 787     }
 788   }
 789   /* Result parked in R1, return via info-pointer at TOS */
 790   R1 = r;
 791   jump %ENTRY_CODE(Sp(0));
 792 }
 793
 794 section "bss" {
 795   exponent:  W_;
 796 }
 797
 798 decodeFloatzh_fast
 799 {
 800     W_ p;
 801     F_ arg;
 802
 803     /* arguments: F1 = Float# */
 804     arg = F1;
 805
 806     ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, decodeFloatzh_fast );
 807
 808     /* Be prepared to tell Lennart-coded __decodeFloat
 809        where mantissa._mp_d can be put (it does not care about the rest) */
 810     p = Hp - SIZEOF_StgArrWords;
 811     SET_HDR(p,stg_ARR_WORDS_info,W_[CCCS]);
 812     StgArrWords_words(p) = 1;
 813     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 814
 815     /* Perform the operation */
 816     foreign "C" __decodeFloat(mp_tmp1,exponent,arg);
 817
 818     /* returns: (Int# (expn), Int#, ByteArray#) */
 819     RET_NNP(W_[exponent], MP_INT__mp_size(mp_tmp1), p);
 820 }
 821
 822 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
 823 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
 824
 825 decodeDoublezh_fast
 826 {
 827     D_ arg;
 828     W_ p;
 829
 830     /* arguments: D1 = Double# */
 831     arg = D1;
 832
 833     ALLOC_PRIM( ARR_SIZE, NO_PTRS, decodeDoublezh_fast );
 834
 835     /* Be prepared to tell Lennart-coded __decodeDouble
 836        where mantissa.d can be put (it does not care about the rest) */
 837     p = Hp - ARR_SIZE + WDS(1);
 838     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 839     StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
 840     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 841
 842     /* Perform the operation */
 843     foreign "C" __decodeDouble(mp_tmp1,exponent,arg);
 844
 845     /* returns: (Int# (expn), Int#, ByteArray#) */
 846     RET_NNP(W_[exponent], MP_INT__mp_size(mp_tmp1), p);
 847 }
 848
 849 /* -----------------------------------------------------------------------------
 850  * Concurrency primitives
 851  * -------------------------------------------------------------------------- */
 852
 853 forkzh_fast
 854 {
 855   /* args: R1 = closure to spark */
 856
 857   MAYBE_GC(R1_PTR, forkzh_fast);
 858
 859   // create it right now, return ThreadID in R1
 860   "ptr" R1 = foreign "C" createIOThread( RtsFlags_GcFlags_initialStkSize(RtsFlags),
 861                                    R1 "ptr");
 862   foreign "C" scheduleThread(R1 "ptr");
 863
 864   // switch at the earliest opportunity
 865   CInt[context_switch] = 1;
 866
 867   RET_P(R1);
 868 }
 869
 870 yieldzh_fast
 871 {
 872   jump stg_yield_noregs;
 873 }
 874
 875 myThreadIdzh_fast
 876 {
 877   /* no args. */
 878   RET_P(CurrentTSO);
 879 }
 880
 881 labelThreadzh_fast
 882 {
 883   /* args:
 884         R1 = ThreadId#
 885         R2 = Addr# */
 886 #ifdef DEBUG
 887   foreign "C" labelThread(R1 "ptr", R2 "ptr");
 888 #endif
 889   jump %ENTRY_CODE(Sp(0));
 890 }
 891
 892 isCurrentThreadBoundzh_fast
 893 {
 894   /* no args */
 895   W_ r;
 896   r = foreign "C" isThreadBound(CurrentTSO);
 897   RET_N(r);
 898 }
 899
 900 /* -----------------------------------------------------------------------------
 901  * MVar primitives
 902  *
 903  * take & putMVar work as follows.  Firstly, an important invariant:
 904  *
 905  *    If the MVar is full, then the blocking queue contains only
 906  *    threads blocked on putMVar, and if the MVar is empty then the
 907  *    blocking queue contains only threads blocked on takeMVar.
 908  *
 909  * takeMvar:
 910  *    MVar empty : then add ourselves to the blocking queue
 911  *    MVar full  : remove the value from the MVar, and
 912  *                 blocking queue empty     : return
 913  *                 blocking queue non-empty : perform the first blocked putMVar
 914  *                                            from the queue, and wake up the
 915  *                                            thread (MVar is now full again)
 916  *
 917  * putMVar is just the dual of the above algorithm.
 918  *
 919  * How do we "perform a putMVar"?  Well, we have to fiddle around with
 920  * the stack of the thread waiting to do the putMVar.  See
 921  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
 922  * the stack layout, and the PerformPut and PerformTake macros below.
 923  *
 924  * It is important that a blocked take or put is woken up with the
 925  * take/put already performed, because otherwise there would be a
 926  * small window of vulnerability where the thread could receive an
 927  * exception and never perform its take or put, and we'd end up with a
 928  * deadlock.
 929  *
 930  * -------------------------------------------------------------------------- */
 931
 932 isEmptyMVarzh_fast
 933 {
 934     /* args: R1 = MVar closure */
 935
 936     if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
 937         RET_N(1);
 938     } else {
 939         RET_N(0);
 940     }
 941 }
 942
 943 newMVarzh_fast
 944 {
 945     /* args: none */
 946     W_ mvar;
 947
 948     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
 949
 950     mvar = Hp - SIZEOF_StgMVar + WDS(1);
 951     SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
 952     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
 953     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
 954     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
 955     RET_P(mvar);
 956 }
 957
 958
 959 /* If R1 isn't available, pass it on the stack */
 960 #ifdef REG_R1
 961 #define PerformTake(tso, value)                         \
 962     W_[StgTSO_sp(tso) + WDS(1)] = value;                \
 963     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
 964 #else
 965 #define PerformTake(tso, value)                                 \
 966     W_[StgTSO_sp(tso) + WDS(1)] = value;                        \
 967     W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
 968 #endif
 969
 970 #define PerformPut(tso,lval)                    \
 971     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);   \
 972     lval = W_[StgTSO_sp(tso) - WDS(1)];
 973
 974
 975 takeMVarzh_fast
 976 {
 977     W_ mvar, val, info, tso;
 978
 979     /* args: R1 = MVar closure */
 980     mvar = R1;
 981
 982     info = GET_INFO(mvar);
 983
 984     /* If the MVar is empty, put ourselves on its blocking queue,
 985      * and wait until we're woken up.
 986      */
 987     if (info == stg_EMPTY_MVAR_info) {
 988         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 989             StgMVar_head(mvar) = CurrentTSO;
 990         } else {
 991             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
 992         }
 993         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
 994         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
 995         StgTSO_block_info(CurrentTSO)  = mvar;
 996         StgMVar_tail(mvar) = CurrentTSO;
 997
 998         jump stg_block_takemvar;
 999   }
1000
1001   /* we got the value... */
1002   val = StgMVar_value(mvar);
1003
1004   if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
1005   {
1006       /* There are putMVar(s) waiting...
1007        * wake up the first thread on the queue
1008        */
1009       ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1010
1011       /* actually perform the putMVar for the thread that we just woke up */
1012       tso = StgMVar_head(mvar);
1013       PerformPut(tso,StgMVar_value(mvar));
1014
1015 #if defined(GRAN) || defined(PAR)
1016       /* ToDo: check 2nd arg (mvar) is right */
1017       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar);
1018       StgMVar_head(mvar) = tso;
1019 #else
1020       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1021       StgMVar_head(mvar) = tso;
1022 #endif
1023       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1024           StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1025       }
1026       RET_P(val);
1027   }
1028   else
1029   {
1030       /* No further putMVars, MVar is now empty */
1031
1032       /* do this last... we might have locked the MVar in the SMP case,
1033        * and writing the info pointer will unlock it.
1034        */
1035       SET_INFO(mvar,stg_EMPTY_MVAR_info);
1036       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1037       RET_P(val);
1038   }
1039 }
1040
1041
1042 tryTakeMVarzh_fast
1043 {
1044     W_ mvar, val, info, tso;
1045
1046     /* args: R1 = MVar closure */
1047
1048     mvar = R1;
1049
1050     info = GET_INFO(mvar);
1051
1052     if (info == stg_EMPTY_MVAR_info) {
1053         /* HACK: we need a pointer to pass back,
1054          * so we abuse NO_FINALIZER_closure
1055          */
1056         RET_NP(0, stg_NO_FINALIZER_closure);
1057     }
1058
1059     /* we got the value... */
1060     val = StgMVar_value(mvar);
1061
1062     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1063         /* There are putMVar(s) waiting...
1064          * wake up the first thread on the queue
1065          */
1066         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1067
1068         /* actually perform the putMVar for the thread that we just woke up */
1069         tso = StgMVar_head(mvar);
1070         PerformPut(tso,StgMVar_value(mvar));
1071
1072 #if defined(GRAN) || defined(PAR)
1073         /* ToDo: check 2nd arg (mvar) is right */
1074         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr");
1075         StgMVar_head(mvar) = tso;
1076 #else
1077         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1078         StgMVar_head(mvar) = tso;
1079 #endif
1080
1081         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1082             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1083         }
1084     }
1085     else
1086     {
1087         /* No further putMVars, MVar is now empty */
1088         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1089
1090         /* do this last... we might have locked the MVar in the SMP case,
1091          * and writing the info pointer will unlock it.
1092          */
1093         SET_INFO(mvar,stg_EMPTY_MVAR_info);
1094     }
1095
1096     RET_NP(1, val);
1097 }
1098
1099
1100 putMVarzh_fast
1101 {
1102     W_ mvar, info, tso;
1103
1104     /* args: R1 = MVar, R2 = value */
1105     mvar = R1;
1106
1107     info = GET_INFO(mvar);
1108
1109     if (info == stg_FULL_MVAR_info) {
1110         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1111             StgMVar_head(mvar) = CurrentTSO;
1112         } else {
1113             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1114         }
1115         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1116         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1117         StgTSO_block_info(CurrentTSO)  = mvar;
1118         StgMVar_tail(mvar) = CurrentTSO;
1119
1120         jump stg_block_putmvar;
1121     }
1122
1123     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1124         /* There are takeMVar(s) waiting: wake up the first one
1125          */
1126         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1127
1128         /* actually perform the takeMVar */
1129         tso = StgMVar_head(mvar);
1130         PerformTake(tso, R2);
1131
1132 #if defined(GRAN) || defined(PAR)
1133         /* ToDo: check 2nd arg (mvar) is right */
1134         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
1135         StgMVar_head(mvar) = tso;
1136 #else
1137         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1138         StgMVar_head(mvar) = tso;
1139 #endif
1140
1141         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1142             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1143         }
1144
1145         jump %ENTRY_CODE(Sp(0));
1146     }
1147     else
1148     {
1149         /* No further takes, the MVar is now full. */
1150         StgMVar_value(mvar) = R2;
1151         /* unlocks the MVar in the SMP case */
1152         SET_INFO(mvar,stg_FULL_MVAR_info);
1153         jump %ENTRY_CODE(Sp(0));
1154     }
1155
1156     /* ToDo: yield afterward for better communication performance? */
1157 }
1158
1159
1160 tryPutMVarzh_fast
1161 {
1162     W_ mvar, info, tso;
1163
1164     /* args: R1 = MVar, R2 = value */
1165     mvar = R1;
1166
1167     info = GET_INFO(mvar);
1168
1169     if (info == stg_FULL_MVAR_info) {
1170         RET_N(0);
1171     }
1172
1173     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1174         /* There are takeMVar(s) waiting: wake up the first one
1175          */
1176         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1177
1178         /* actually perform the takeMVar */
1179         tso = StgMVar_head(mvar);
1180         PerformTake(tso, R2);
1181
1182 #if defined(GRAN) || defined(PAR)
1183         /* ToDo: check 2nd arg (mvar) is right */
1184         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
1185         StgMVar_head(mvar) = tso;
1186 #else
1187         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1188         StgMVar_head(mvar) = tso;
1189 #endif
1190
1191         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1192             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1193         }
1194
1195         jump %ENTRY_CODE(Sp(0));
1196     }
1197     else
1198     {
1199         /* No further takes, the MVar is now full. */
1200         StgMVar_value(mvar) = R2;
1201         /* unlocks the MVar in the SMP case */
1202         SET_INFO(mvar,stg_FULL_MVAR_info);
1203         jump %ENTRY_CODE(Sp(0));
1204     }
1205
1206     /* ToDo: yield afterward for better communication performance? */
1207 }
1208
1209
1210 /* -----------------------------------------------------------------------------
1211    Stable pointer primitives
1212    -------------------------------------------------------------------------  */
1213
1214 makeStableNamezh_fast
1215 {
1216     W_ index, sn_obj;
1217
1218     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
1219
1220     index = foreign "C" lookupStableName(R1 "ptr");
1221
1222     /* Is there already a StableName for this heap object?
1223      *  stable_ptr_table is an array of snEntry structs.
1224      */
1225     if ( snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) == NULL ) {
1226         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1227         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1228         StgStableName_sn(sn_obj) = index;
1229         snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) = sn_obj;
1230     } else {
1231         sn_obj = snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry);
1232     }
1233
1234     RET_P(sn_obj);
1235 }
1236
1237
1238 makeStablePtrzh_fast
1239 {
1240     /* Args: R1 = a */
1241     W_ sp;
1242     MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1243     "ptr" sp = foreign "C" getStablePtr(R1 "ptr");
1244     RET_N(sp);
1245 }
1246
1247 deRefStablePtrzh_fast
1248 {
1249     /* Args: R1 = the stable ptr */
1250     W_ r, sp;
1251     sp = R1;
1252     r = snEntry_addr(stable_ptr_table + sp*SIZEOF_snEntry);
1253     RET_P(r);
1254 }
1255
1256 /* -----------------------------------------------------------------------------
1257    Bytecode object primitives
1258    -------------------------------------------------------------------------  */
1259
1260 newBCOzh_fast
1261 {
1262     /* R1 = instrs
1263        R2 = literals
1264        R3 = ptrs
1265        R4 = itbls
1266        R5 = arity
1267        R6 = bitmap array
1268     */
1269     W_ bco, bitmap_arr, bytes, words;
1270
1271     bitmap_arr = R6;
1272     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1273     bytes = WDS(words);
1274
1275     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
1276
1277     bco = Hp - bytes + WDS(1);
1278     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1279
1280     StgBCO_instrs(bco)     = R1;
1281     StgBCO_literals(bco)   = R2;
1282     StgBCO_ptrs(bco)       = R3;
1283     StgBCO_itbls(bco)      = R4;
1284     StgBCO_arity(bco)      = HALF_W_(R5);
1285     StgBCO_size(bco)       = HALF_W_(words);
1286
1287     // Copy the arity/bitmap info into the BCO
1288     W_ i;
1289     i = 0;
1290 for:
1291     if (i < StgArrWords_words(bitmap_arr)) {
1292         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1293         i = i + 1;
1294         goto for;
1295     }
1296
1297     RET_P(bco);
1298 }
1299
1300
1301 mkApUpd0zh_fast
1302 {
1303     // R1 = the BCO# for the AP
1304     //
1305     W_ ap;
1306
1307     // This function is *only* used to wrap zero-arity BCOs in an
1308     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1309     // saturated and always points directly to a FUN or BCO.
1310     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == BCO::I16 &&
1311            StgBCO_arity(R1) == 0::I16);
1312
1313     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
1314     TICK_ALLOC_UP_THK(0, 0);
1315     CCCS_ALLOC(SIZEOF_StgAP);
1316
1317     ap = Hp - SIZEOF_StgAP + WDS(1);
1318     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1319
1320     StgAP_n_args(ap) = 0::I16;
1321     StgAP_fun(ap) = R1;
1322
1323     RET_P(ap);
1324 }
1325
1326 /* -----------------------------------------------------------------------------
1327    Thread I/O blocking primitives
1328    -------------------------------------------------------------------------- */
1329
1330 /* Add a thread to the end of the blocked queue. (C-- version of the C
1331  * macro in Schedule.h).
1332  */
1333 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1334     ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);          \
1335     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1336       W_[blocked_queue_hd] = tso;                       \
1337     } else {                                            \
1338       StgTSO_link(W_[blocked_queue_tl]) = tso;          \
1339     }                                                   \
1340     W_[blocked_queue_tl] = tso;
1341
1342 waitReadzh_fast
1343 {
1344     /* args: R1 */
1345 #ifdef THREADED_RTS
1346     foreign "C" barf("waitRead# on threaded RTS");
1347 #endif
1348
1349     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1350     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1351     StgTSO_block_info(CurrentTSO) = R1;
1352     // No locking - we're not going to use this interface in the
1353     // threaded RTS anyway.
1354     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1355     jump stg_block_noregs;
1356 }
1357
1358 waitWritezh_fast
1359 {
1360     /* args: R1 */
1361 #ifdef THREADED_RTS
1362     foreign "C" barf("waitWrite# on threaded RTS");
1363 #endif
1364
1365     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1366     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1367     StgTSO_block_info(CurrentTSO) = R1;
1368     // No locking - we're not going to use this interface in the
1369     // threaded RTS anyway.
1370     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1371     jump stg_block_noregs;
1372 }
1373
1374
1375 STRING(stg_delayzh_malloc_str, "delayzh_fast")
1376 delayzh_fast
1377 {
1378 #ifdef mingw32_TARGET_OS
1379     W_ ares;
1380     CInt reqID;
1381 #else
1382     W_ t, prev, target;
1383 #endif
1384
1385 #ifdef THREADED_RTS
1386     foreign "C" barf("delay# on threaded RTS");
1387 #endif
1388
1389     /* args: R1 (microsecond delay amount) */
1390     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1391     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1392
1393 #ifdef mingw32_TARGET_OS
1394
1395     /* could probably allocate this on the heap instead */
1396     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1397                                             stg_delayzh_malloc_str);
1398     reqID = foreign "C" addDelayRequest(R1);
1399     StgAsyncIOResult_reqID(ares)   = reqID;
1400     StgAsyncIOResult_len(ares)     = 0;
1401     StgAsyncIOResult_errCode(ares) = 0;
1402     StgTSO_block_info(CurrentTSO)  = ares;
1403
1404     /* Having all async-blocked threads reside on the blocked_queue
1405      * simplifies matters, so change the status to OnDoProc put the
1406      * delayed thread on the blocked_queue.
1407      */
1408     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1409     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1410     jump stg_block_async_void;
1411
1412 #else
1413
1414     CInt time;
1415     time = foreign "C" getourtimeofday();
1416     target = (R1 / (TICK_MILLISECS*1000)) + TO_W_(time);
1417     StgTSO_block_info(CurrentTSO) = target;
1418
1419     /* Insert the new thread in the sleeping queue. */
1420     prev = NULL;
1421     t = W_[sleeping_queue];
1422 while:
1423     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1424         prev = t;
1425         t = StgTSO_link(t);
1426         goto while;
1427     }
1428
1429     StgTSO_link(CurrentTSO) = t;
1430     if (prev == NULL) {
1431         W_[sleeping_queue] = CurrentTSO;
1432     } else {
1433         StgTSO_link(prev) = CurrentTSO;
1434     }
1435     jump stg_block_noregs;
1436 #endif
1437 }
1438
1439
1440 #ifdef mingw32_TARGET_OS
1441 STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
1442 asyncReadzh_fast
1443 {
1444     W_ ares;
1445     CInt reqID;
1446
1447 #ifdef THREADED_RTS
1448     foreign "C" barf("asyncRead# on threaded RTS");
1449 #endif
1450
1451     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1452     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1453     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1454
1455     /* could probably allocate this on the heap instead */
1456     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1457                                             stg_asyncReadzh_malloc_str);
1458     reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr");
1459     StgAsyncIOResult_reqID(ares)   = reqID;
1460     StgAsyncIOResult_len(ares)     = 0;
1461     StgAsyncIOResult_errCode(ares) = 0;
1462     StgTSO_block_info(CurrentTSO)  = ares;
1463     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1464     jump stg_block_async;
1465 }
1466
1467 STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
1468 asyncWritezh_fast
1469 {
1470     W_ ares;
1471     CInt reqID;
1472
1473 #ifdef THREADED_RTS
1474     foreign "C" barf("asyncWrite# on threaded RTS");
1475 #endif
1476
1477     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1478     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1479     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1480
1481     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1482                                             stg_asyncWritezh_malloc_str);
1483     reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr");
1484
1485     StgAsyncIOResult_reqID(ares)   = reqID;
1486     StgAsyncIOResult_len(ares)     = 0;
1487     StgAsyncIOResult_errCode(ares) = 0;
1488     StgTSO_block_info(CurrentTSO)  = ares;
1489     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1490     jump stg_block_async;
1491 }
1492
1493 STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
1494 asyncDoProczh_fast
1495 {
1496     W_ ares;
1497     CInt reqID;
1498
1499     /* args: R1 = proc, R2 = param */
1500     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1501     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1502
1503     /* could probably allocate this on the heap instead */
1504     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1505                                             stg_asyncDoProczh_malloc_str);
1506     reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr");
1507     StgAsyncIOResult_reqID(ares)   = reqID;
1508     StgAsyncIOResult_len(ares)     = 0;
1509     StgAsyncIOResult_errCode(ares) = 0;
1510     StgTSO_block_info(CurrentTSO) = ares;
1511     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1512     jump stg_block_async;
1513 }
1514 #endif
1515
1516 /* -----------------------------------------------------------------------------
1517   ** temporary **
1518
1519    classes CCallable and CReturnable don't really exist, but the
1520    compiler insists on generating dictionaries containing references
1521    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
1522    for these.  Some C compilers can't cope with zero-length static arrays,
1523    so we have to make these one element long.
1524   --------------------------------------------------------------------------- */
1525
1526 section "rodata" {
1527   GHC_ZCCCallable_static_info:   W_ 0;
1528 }
1529
1530 section "rodata" {
1531   GHC_ZCCReturnable_static_info: W_ 0;
1532 }