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   CInt s1, s2;                                          \
 542   W_ d1, d2;                                            \
 543                                                         \
 544   /* call doYouWantToGC() */                            \
 545   MAYBE_GC(R2_PTR & R4_PTR, name);                      \
 546                                                         \
 547   s1 = W_TO_INT(R1);                                    \
 548   d1 = R2;                                              \
 549   s2 = W_TO_INT(R3);                                    \
 550   d2 = R4;                                              \
 551                                                         \
 552   MP_INT__mp_alloc(mp_tmp1) = W_TO_INT(StgArrWords_words(d1));  \
 553   MP_INT__mp_size(mp_tmp1)  = (s1);                     \
 554   MP_INT__mp_d(mp_tmp1)     = BYTE_ARR_CTS(d1);         \
 555   MP_INT__mp_alloc(mp_tmp2) = W_TO_INT(StgArrWords_words(d2));  \
 556   MP_INT__mp_size(mp_tmp2)  = (s2);                     \
 557   MP_INT__mp_d(mp_tmp2)     = BYTE_ARR_CTS(d2);         \
 558                                                         \
 559   foreign "C" mpz_init(result1);                        \
 560                                                         \
 561   /* Perform the operation */                           \
 562   foreign "C" mp_fun(result1,mp_tmp1,mp_tmp2);          \
 563                                                         \
 564   RET_NP(TO_W_(MP_INT__mp_size(result1)),               \
 565          MP_INT__mp_d(result1) - SIZEOF_StgArrWords);   \
 566 }
 567
 568 #define GMP_TAKE1_RET1(name,mp_fun)                             \
 569 name                                                            \
 570 {                                                               \
 571   CInt s1;                                                      \
 572   W_ d1;                                                        \
 573                                                                 \
 574   /* call doYouWantToGC() */                                    \
 575   MAYBE_GC(R2_PTR, name);                                       \
 576                                                                 \
 577   d1 = R2;                                                      \
 578   s1 = W_TO_INT(R1);                                            \
 579                                                                 \
 580   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));      \
 581   MP_INT__mp_size(mp_tmp1)      = (s1);                         \
 582   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);             \
 583                                                                 \
 584   foreign "C" mpz_init(result1);                                \
 585                                                                 \
 586   /* Perform the operation */                                   \
 587   foreign "C" mp_fun(result1,mp_tmp1);                          \
 588                                                                 \
 589   RET_NP(TO_W_(MP_INT__mp_size(result1)),                       \
 590          MP_INT__mp_d(result1) - SIZEOF_StgArrWords);           \
 591 }
 592
 593 #define GMP_TAKE2_RET2(name,mp_fun)                             \
 594 name                                                            \
 595 {                                                               \
 596   CInt s1, s2;                                                  \
 597   W_ d1, d2;                                                    \
 598                                                                 \
 599   /* call doYouWantToGC() */                                    \
 600   MAYBE_GC(R2_PTR & R4_PTR, name);                              \
 601                                                                 \
 602   s1 = W_TO_INT(R1);                                            \
 603   d1 = R2;                                                      \
 604   s2 = W_TO_INT(R3);                                            \
 605   d2 = R4;                                                      \
 606                                                                 \
 607   MP_INT__mp_alloc(mp_tmp1)     = W_TO_INT(StgArrWords_words(d1));      \
 608   MP_INT__mp_size(mp_tmp1)      = (s1);                         \
 609   MP_INT__mp_d(mp_tmp1)         = BYTE_ARR_CTS(d1);             \
 610   MP_INT__mp_alloc(mp_tmp2)     = W_TO_INT(StgArrWords_words(d2));      \
 611   MP_INT__mp_size(mp_tmp2)      = (s2);                         \
 612   MP_INT__mp_d(mp_tmp2)         = BYTE_ARR_CTS(d2);             \
 613                                                                 \
 614   foreign "C" mpz_init(result1);                                \
 615   foreign "C" mpz_init(result2);                                \
 616                                                                 \
 617   /* Perform the operation */                                   \
 618   foreign "C" mp_fun(result1,result2,mp_tmp1,mp_tmp2);          \
 619                                                                 \
 620   RET_NPNP(TO_W_(MP_INT__mp_size(result1)),                     \
 621            MP_INT__mp_d(result1) - SIZEOF_StgArrWords,          \
 622            TO_W_(MP_INT__mp_size(result2)),                     \
 623            MP_INT__mp_d(result2) - SIZEOF_StgArrWords);         \
 624 }
 625
 626 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add)
 627 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub)
 628 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul)
 629 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd)
 630 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q)
 631 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r)
 632 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact)
 633 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and)
 634 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior)
 635 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor)
 636 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com)
 637
 638 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr)
 639 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr)
 640
 641 section "bss" {
 642   aa:  W_; // NB. aa is really an mp_limb_t
 643 }
 644
 645 gcdIntzh_fast
 646 {
 647     /* R1 = the first Int#; R2 = the second Int# */
 648     W_ r;
 649
 650     W_[aa] = R1;
 651     r = foreign "C" mpn_gcd_1(aa, 1, R2);
 652
 653     R1 = r;
 654     /* Result parked in R1, return via info-pointer at TOS */
 655     jump %ENTRY_CODE(Sp(0));
 656 }
 657
 658
 659 gcdIntegerIntzh_fast
 660 {
 661     /* R1 = s1; R2 = d1; R3 = the int */
 662     R1 = foreign "C" mpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3);
 663
 664     /* Result parked in R1, return via info-pointer at TOS */
 665     jump %ENTRY_CODE(Sp(0));
 666 }
 667
 668
 669 cmpIntegerIntzh_fast
 670 {
 671     /* R1 = s1; R2 = d1; R3 = the int */
 672     W_ usize, vsize, v_digit, u_digit;
 673
 674     usize = R1;
 675     vsize = 0;
 676     v_digit = R3;
 677
 678     // paraphrased from mpz_cmp_si() in the GMP sources
 679     if (%gt(v_digit,0)) {
 680         vsize = 1;
 681     } else {
 682         if (%lt(v_digit,0)) {
 683             vsize = -1;
 684             v_digit = -v_digit;
 685         }
 686     }
 687
 688     if (usize != vsize) {
 689         R1 = usize - vsize;
 690         jump %ENTRY_CODE(Sp(0));
 691     }
 692
 693     if (usize == 0) {
 694         R1 = 0;
 695         jump %ENTRY_CODE(Sp(0));
 696     }
 697
 698     u_digit = W_[BYTE_ARR_CTS(R2)];
 699
 700     if (u_digit == v_digit) {
 701         R1 = 0;
 702         jump %ENTRY_CODE(Sp(0));
 703     }
 704
 705     if (%gtu(u_digit,v_digit)) { // NB. unsigned: these are mp_limb_t's
 706         R1 = usize;
 707     } else {
 708         R1 = -usize;
 709     }
 710
 711     jump %ENTRY_CODE(Sp(0));
 712 }
 713
 714 cmpIntegerzh_fast
 715 {
 716     /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
 717     W_ usize, vsize, size, up, vp;
 718     CInt cmp;
 719
 720     // paraphrased from mpz_cmp() in the GMP sources
 721     usize = R1;
 722     vsize = R3;
 723
 724     if (usize != vsize) {
 725         R1 = usize - vsize;
 726         jump %ENTRY_CODE(Sp(0));
 727     }
 728
 729     if (usize == 0) {
 730         R1 = 0;
 731         jump %ENTRY_CODE(Sp(0));
 732     }
 733
 734     if (%lt(usize,0)) { // NB. not <, which is unsigned
 735         size = -usize;
 736     } else {
 737         size = usize;
 738     }
 739
 740     up = BYTE_ARR_CTS(R2);
 741     vp = BYTE_ARR_CTS(R4);
 742
 743     cmp = foreign "C" mpn_cmp(up "ptr", vp "ptr", size);
 744
 745     if (cmp == 0 :: CInt) {
 746         R1 = 0;
 747         jump %ENTRY_CODE(Sp(0));
 748     }
 749
 750     if (%lt(cmp,0 :: CInt) == %lt(usize,0)) {
 751         R1 = 1;
 752     } else {
 753         R1 = (-1);
 754     }
 755     /* Result parked in R1, return via info-pointer at TOS */
 756     jump %ENTRY_CODE(Sp(0));
 757 }
 758
 759 integer2Intzh_fast
 760 {
 761     /* R1 = s; R2 = d */
 762     W_ r, s;
 763
 764     s = R1;
 765     if (s == 0) {
 766         r = 0;
 767     } else {
 768         r = W_[R2 + SIZEOF_StgArrWords];
 769         if (%lt(s,0)) {
 770             r = -r;
 771         }
 772     }
 773     /* Result parked in R1, return via info-pointer at TOS */
 774     R1 = r;
 775     jump %ENTRY_CODE(Sp(0));
 776 }
 777
 778 integer2Wordzh_fast
 779 {
 780   /* R1 = s; R2 = d */
 781   W_ r, s;
 782
 783   s = R1;
 784   if (s == 0) {
 785     r = 0;
 786   } else {
 787     r = W_[R2 + SIZEOF_StgArrWords];
 788     if (%lt(s,0)) {
 789         r = -r;
 790     }
 791   }
 792   /* Result parked in R1, return via info-pointer at TOS */
 793   R1 = r;
 794   jump %ENTRY_CODE(Sp(0));
 795 }
 796
 797 section "bss" {
 798   exponent:  W_;
 799 }
 800
 801 decodeFloatzh_fast
 802 {
 803     W_ p;
 804     F_ arg;
 805
 806     /* arguments: F1 = Float# */
 807     arg = F1;
 808
 809     ALLOC_PRIM( SIZEOF_StgArrWords + WDS(1), NO_PTRS, decodeFloatzh_fast );
 810
 811     /* Be prepared to tell Lennart-coded __decodeFloat
 812        where mantissa._mp_d can be put (it does not care about the rest) */
 813     p = Hp - SIZEOF_StgArrWords;
 814     SET_HDR(p,stg_ARR_WORDS_info,W_[CCCS]);
 815     StgArrWords_words(p) = 1;
 816     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 817
 818     /* Perform the operation */
 819     foreign "C" __decodeFloat(mp_tmp1,exponent,arg);
 820
 821     /* returns: (Int# (expn), Int#, ByteArray#) */
 822     RET_NNP(W_[exponent], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 823 }
 824
 825 #define DOUBLE_MANTISSA_SIZE SIZEOF_DOUBLE
 826 #define ARR_SIZE (SIZEOF_StgArrWords + DOUBLE_MANTISSA_SIZE)
 827
 828 decodeDoublezh_fast
 829 {
 830     D_ arg;
 831     W_ p;
 832
 833     /* arguments: D1 = Double# */
 834     arg = D1;
 835
 836     ALLOC_PRIM( ARR_SIZE, NO_PTRS, decodeDoublezh_fast );
 837
 838     /* Be prepared to tell Lennart-coded __decodeDouble
 839        where mantissa.d can be put (it does not care about the rest) */
 840     p = Hp - ARR_SIZE + WDS(1);
 841     SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
 842     StgArrWords_words(p) = BYTES_TO_WDS(DOUBLE_MANTISSA_SIZE);
 843     MP_INT__mp_d(mp_tmp1) = BYTE_ARR_CTS(p);
 844
 845     /* Perform the operation */
 846     foreign "C" __decodeDouble(mp_tmp1,exponent,arg);
 847
 848     /* returns: (Int# (expn), Int#, ByteArray#) */
 849     RET_NNP(W_[exponent], TO_W_(MP_INT__mp_size(mp_tmp1)), p);
 850 }
 851
 852 /* -----------------------------------------------------------------------------
 853  * Concurrency primitives
 854  * -------------------------------------------------------------------------- */
 855
 856 forkzh_fast
 857 {
 858   /* args: R1 = closure to spark */
 859
 860   MAYBE_GC(R1_PTR, forkzh_fast);
 861
 862   // create it right now, return ThreadID in R1
 863   "ptr" R1 = foreign "C" createIOThread( RtsFlags_GcFlags_initialStkSize(RtsFlags),
 864                                    R1 "ptr");
 865   foreign "C" scheduleThread(R1 "ptr");
 866
 867   // switch at the earliest opportunity
 868   CInt[context_switch] = 1 :: CInt;
 869
 870   RET_P(R1);
 871 }
 872
 873 yieldzh_fast
 874 {
 875   jump stg_yield_noregs;
 876 }
 877
 878 myThreadIdzh_fast
 879 {
 880   /* no args. */
 881   RET_P(CurrentTSO);
 882 }
 883
 884 labelThreadzh_fast
 885 {
 886   /* args:
 887         R1 = ThreadId#
 888         R2 = Addr# */
 889 #ifdef DEBUG
 890   foreign "C" labelThread(R1 "ptr", R2 "ptr");
 891 #endif
 892   jump %ENTRY_CODE(Sp(0));
 893 }
 894
 895 isCurrentThreadBoundzh_fast
 896 {
 897   /* no args */
 898   W_ r;
 899   r = foreign "C" isThreadBound(CurrentTSO);
 900   RET_N(r);
 901 }
 902
 903 /* -----------------------------------------------------------------------------
 904  * MVar primitives
 905  *
 906  * take & putMVar work as follows.  Firstly, an important invariant:
 907  *
 908  *    If the MVar is full, then the blocking queue contains only
 909  *    threads blocked on putMVar, and if the MVar is empty then the
 910  *    blocking queue contains only threads blocked on takeMVar.
 911  *
 912  * takeMvar:
 913  *    MVar empty : then add ourselves to the blocking queue
 914  *    MVar full  : remove the value from the MVar, and
 915  *                 blocking queue empty     : return
 916  *                 blocking queue non-empty : perform the first blocked putMVar
 917  *                                            from the queue, and wake up the
 918  *                                            thread (MVar is now full again)
 919  *
 920  * putMVar is just the dual of the above algorithm.
 921  *
 922  * How do we "perform a putMVar"?  Well, we have to fiddle around with
 923  * the stack of the thread waiting to do the putMVar.  See
 924  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
 925  * the stack layout, and the PerformPut and PerformTake macros below.
 926  *
 927  * It is important that a blocked take or put is woken up with the
 928  * take/put already performed, because otherwise there would be a
 929  * small window of vulnerability where the thread could receive an
 930  * exception and never perform its take or put, and we'd end up with a
 931  * deadlock.
 932  *
 933  * -------------------------------------------------------------------------- */
 934
 935 isEmptyMVarzh_fast
 936 {
 937     /* args: R1 = MVar closure */
 938
 939     if (GET_INFO(R1) == stg_EMPTY_MVAR_info) {
 940         RET_N(1);
 941     } else {
 942         RET_N(0);
 943     }
 944 }
 945
 946 newMVarzh_fast
 947 {
 948     /* args: none */
 949     W_ mvar;
 950
 951     ALLOC_PRIM ( SIZEOF_StgMVar, NO_PTRS, newMVarzh_fast );
 952
 953     mvar = Hp - SIZEOF_StgMVar + WDS(1);
 954     SET_HDR(mvar,stg_EMPTY_MVAR_info,W_[CCCS]);
 955     StgMVar_head(mvar)  = stg_END_TSO_QUEUE_closure;
 956     StgMVar_tail(mvar)  = stg_END_TSO_QUEUE_closure;
 957     StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
 958     RET_P(mvar);
 959 }
 960
 961
 962 /* If R1 isn't available, pass it on the stack */
 963 #ifdef REG_R1
 964 #define PerformTake(tso, value)                         \
 965     W_[StgTSO_sp(tso) + WDS(1)] = value;                \
 966     W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info;
 967 #else
 968 #define PerformTake(tso, value)                                 \
 969     W_[StgTSO_sp(tso) + WDS(1)] = value;                        \
 970     W_[StgTSO_sp(tso) + WDS(0)] = stg_ut_1_0_unreg_info;
 971 #endif
 972
 973 #define PerformPut(tso,lval)                    \
 974     StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3);   \
 975     lval = W_[StgTSO_sp(tso) - WDS(1)];
 976
 977
 978 takeMVarzh_fast
 979 {
 980     W_ mvar, val, info, tso;
 981
 982     /* args: R1 = MVar closure */
 983     mvar = R1;
 984
 985     info = GET_INFO(mvar);
 986
 987     /* If the MVar is empty, put ourselves on its blocking queue,
 988      * and wait until we're woken up.
 989      */
 990     if (info == stg_EMPTY_MVAR_info) {
 991         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
 992             StgMVar_head(mvar) = CurrentTSO;
 993         } else {
 994             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
 995         }
 996         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
 997         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
 998         StgTSO_block_info(CurrentTSO)  = mvar;
 999         StgMVar_tail(mvar) = CurrentTSO;
1000
1001         jump stg_block_takemvar;
1002   }
1003
1004   /* we got the value... */
1005   val = StgMVar_value(mvar);
1006
1007   if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure)
1008   {
1009       /* There are putMVar(s) waiting...
1010        * wake up the first thread on the queue
1011        */
1012       ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1013
1014       /* actually perform the putMVar for the thread that we just woke up */
1015       tso = StgMVar_head(mvar);
1016       PerformPut(tso,StgMVar_value(mvar));
1017
1018 #if defined(GRAN) || defined(PAR)
1019       /* ToDo: check 2nd arg (mvar) is right */
1020       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar);
1021       StgMVar_head(mvar) = tso;
1022 #else
1023       "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1024       StgMVar_head(mvar) = tso;
1025 #endif
1026       if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1027           StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1028       }
1029       RET_P(val);
1030   }
1031   else
1032   {
1033       /* No further putMVars, MVar is now empty */
1034
1035       /* do this last... we might have locked the MVar in the SMP case,
1036        * and writing the info pointer will unlock it.
1037        */
1038       SET_INFO(mvar,stg_EMPTY_MVAR_info);
1039       StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1040       RET_P(val);
1041   }
1042 }
1043
1044
1045 tryTakeMVarzh_fast
1046 {
1047     W_ mvar, val, info, tso;
1048
1049     /* args: R1 = MVar closure */
1050
1051     mvar = R1;
1052
1053     info = GET_INFO(mvar);
1054
1055     if (info == stg_EMPTY_MVAR_info) {
1056         /* HACK: we need a pointer to pass back,
1057          * so we abuse NO_FINALIZER_closure
1058          */
1059         RET_NP(0, stg_NO_FINALIZER_closure);
1060     }
1061
1062     /* we got the value... */
1063     val = StgMVar_value(mvar);
1064
1065     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1066         /* There are putMVar(s) waiting...
1067          * wake up the first thread on the queue
1068          */
1069         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1070
1071         /* actually perform the putMVar for the thread that we just woke up */
1072         tso = StgMVar_head(mvar);
1073         PerformPut(tso,StgMVar_value(mvar));
1074
1075 #if defined(GRAN) || defined(PAR)
1076         /* ToDo: check 2nd arg (mvar) is right */
1077         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr");
1078         StgMVar_head(mvar) = tso;
1079 #else
1080         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1081         StgMVar_head(mvar) = tso;
1082 #endif
1083
1084         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1085             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1086         }
1087     }
1088     else
1089     {
1090         /* No further putMVars, MVar is now empty */
1091         StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure;
1092
1093         /* do this last... we might have locked the MVar in the SMP case,
1094          * and writing the info pointer will unlock it.
1095          */
1096         SET_INFO(mvar,stg_EMPTY_MVAR_info);
1097     }
1098
1099     RET_NP(1, val);
1100 }
1101
1102
1103 putMVarzh_fast
1104 {
1105     W_ mvar, info, tso;
1106
1107     /* args: R1 = MVar, R2 = value */
1108     mvar = R1;
1109
1110     info = GET_INFO(mvar);
1111
1112     if (info == stg_FULL_MVAR_info) {
1113         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1114             StgMVar_head(mvar) = CurrentTSO;
1115         } else {
1116             StgTSO_link(StgMVar_tail(mvar)) = CurrentTSO;
1117         }
1118         StgTSO_link(CurrentTSO)        = stg_END_TSO_QUEUE_closure;
1119         StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16;
1120         StgTSO_block_info(CurrentTSO)  = mvar;
1121         StgMVar_tail(mvar) = CurrentTSO;
1122
1123         jump stg_block_putmvar;
1124     }
1125
1126     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1127         /* There are takeMVar(s) waiting: wake up the first one
1128          */
1129         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1130
1131         /* actually perform the takeMVar */
1132         tso = StgMVar_head(mvar);
1133         PerformTake(tso, R2);
1134
1135 #if defined(GRAN) || defined(PAR)
1136         /* ToDo: check 2nd arg (mvar) is right */
1137         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
1138         StgMVar_head(mvar) = tso;
1139 #else
1140         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1141         StgMVar_head(mvar) = tso;
1142 #endif
1143
1144         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1145             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1146         }
1147
1148         jump %ENTRY_CODE(Sp(0));
1149     }
1150     else
1151     {
1152         /* No further takes, the MVar is now full. */
1153         StgMVar_value(mvar) = R2;
1154         /* unlocks the MVar in the SMP case */
1155         SET_INFO(mvar,stg_FULL_MVAR_info);
1156         jump %ENTRY_CODE(Sp(0));
1157     }
1158
1159     /* ToDo: yield afterward for better communication performance? */
1160 }
1161
1162
1163 tryPutMVarzh_fast
1164 {
1165     W_ mvar, info, tso;
1166
1167     /* args: R1 = MVar, R2 = value */
1168     mvar = R1;
1169
1170     info = GET_INFO(mvar);
1171
1172     if (info == stg_FULL_MVAR_info) {
1173         RET_N(0);
1174     }
1175
1176     if (StgMVar_head(mvar) != stg_END_TSO_QUEUE_closure) {
1177         /* There are takeMVar(s) waiting: wake up the first one
1178          */
1179         ASSERT(StgTSO_why_blocked(StgMVar_head(mvar)) == BlockedOnMVar::I16);
1180
1181         /* actually perform the takeMVar */
1182         tso = StgMVar_head(mvar);
1183         PerformTake(tso, R2);
1184
1185 #if defined(GRAN) || defined(PAR)
1186         /* ToDo: check 2nd arg (mvar) is right */
1187         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr",mvar "ptr");
1188         StgMVar_head(mvar) = tso;
1189 #else
1190         "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr");
1191         StgMVar_head(mvar) = tso;
1192 #endif
1193
1194         if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) {
1195             StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure;
1196         }
1197
1198         jump %ENTRY_CODE(Sp(0));
1199     }
1200     else
1201     {
1202         /* No further takes, the MVar is now full. */
1203         StgMVar_value(mvar) = R2;
1204         /* unlocks the MVar in the SMP case */
1205         SET_INFO(mvar,stg_FULL_MVAR_info);
1206         jump %ENTRY_CODE(Sp(0));
1207     }
1208
1209     /* ToDo: yield afterward for better communication performance? */
1210 }
1211
1212
1213 /* -----------------------------------------------------------------------------
1214    Stable pointer primitives
1215    -------------------------------------------------------------------------  */
1216
1217 makeStableNamezh_fast
1218 {
1219     W_ index, sn_obj;
1220
1221     ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
1222
1223     index = foreign "C" lookupStableName(R1 "ptr");
1224
1225     /* Is there already a StableName for this heap object?
1226      *  stable_ptr_table is an array of snEntry structs.
1227      */
1228     if ( snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) == NULL ) {
1229         sn_obj = Hp - SIZEOF_StgStableName + WDS(1);
1230         SET_HDR(sn_obj, stg_STABLE_NAME_info, W_[CCCS]);
1231         StgStableName_sn(sn_obj) = index;
1232         snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry) = sn_obj;
1233     } else {
1234         sn_obj = snEntry_sn_obj(stable_ptr_table + index*SIZEOF_snEntry);
1235     }
1236
1237     RET_P(sn_obj);
1238 }
1239
1240
1241 makeStablePtrzh_fast
1242 {
1243     /* Args: R1 = a */
1244     W_ sp;
1245     MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1246     "ptr" sp = foreign "C" getStablePtr(R1 "ptr");
1247     RET_N(sp);
1248 }
1249
1250 deRefStablePtrzh_fast
1251 {
1252     /* Args: R1 = the stable ptr */
1253     W_ r, sp;
1254     sp = R1;
1255     r = snEntry_addr(stable_ptr_table + sp*SIZEOF_snEntry);
1256     RET_P(r);
1257 }
1258
1259 /* -----------------------------------------------------------------------------
1260    Bytecode object primitives
1261    -------------------------------------------------------------------------  */
1262
1263 newBCOzh_fast
1264 {
1265     /* R1 = instrs
1266        R2 = literals
1267        R3 = ptrs
1268        R4 = itbls
1269        R5 = arity
1270        R6 = bitmap array
1271     */
1272     W_ bco, bitmap_arr, bytes, words;
1273
1274     bitmap_arr = R6;
1275     words = BYTES_TO_WDS(SIZEOF_StgBCO) + StgArrWords_words(bitmap_arr);
1276     bytes = WDS(words);
1277
1278     ALLOC_PRIM( bytes, R1_PTR&R2_PTR&R3_PTR&R4_PTR&R6_PTR, newBCOzh_fast );
1279
1280     bco = Hp - bytes + WDS(1);
1281     SET_HDR(bco, stg_BCO_info, W_[CCCS]);
1282
1283     StgBCO_instrs(bco)     = R1;
1284     StgBCO_literals(bco)   = R2;
1285     StgBCO_ptrs(bco)       = R3;
1286     StgBCO_itbls(bco)      = R4;
1287     StgBCO_arity(bco)      = HALF_W_(R5);
1288     StgBCO_size(bco)       = HALF_W_(words);
1289
1290     // Copy the arity/bitmap info into the BCO
1291     W_ i;
1292     i = 0;
1293 for:
1294     if (i < StgArrWords_words(bitmap_arr)) {
1295         StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i);
1296         i = i + 1;
1297         goto for;
1298     }
1299
1300     RET_P(bco);
1301 }
1302
1303
1304 mkApUpd0zh_fast
1305 {
1306     // R1 = the BCO# for the AP
1307     //
1308     W_ ap;
1309
1310     // This function is *only* used to wrap zero-arity BCOs in an
1311     // updatable wrapper (see ByteCodeLink.lhs).  An AP thunk is always
1312     // saturated and always points directly to a FUN or BCO.
1313     ASSERT(%INFO_TYPE(%GET_STD_INFO(R1)) == HALF_W_(BCO) &&
1314            StgBCO_arity(R1) == HALF_W_(0));
1315
1316     HP_CHK_GEN_TICKY(SIZEOF_StgAP, R1_PTR, mkApUpd0zh_fast);
1317     TICK_ALLOC_UP_THK(0, 0);
1318     CCCS_ALLOC(SIZEOF_StgAP);
1319
1320     ap = Hp - SIZEOF_StgAP + WDS(1);
1321     SET_HDR(ap, stg_AP_info, W_[CCCS]);
1322
1323     StgAP_n_args(ap) = HALF_W_(0);
1324     StgAP_fun(ap) = R1;
1325
1326     RET_P(ap);
1327 }
1328
1329 /* -----------------------------------------------------------------------------
1330    Thread I/O blocking primitives
1331    -------------------------------------------------------------------------- */
1332
1333 /* Add a thread to the end of the blocked queue. (C-- version of the C
1334  * macro in Schedule.h).
1335  */
1336 #define APPEND_TO_BLOCKED_QUEUE(tso)                    \
1337     ASSERT(StgTSO_link(tso) == END_TSO_QUEUE);          \
1338     if (W_[blocked_queue_hd] == END_TSO_QUEUE) {        \
1339       W_[blocked_queue_hd] = tso;                       \
1340     } else {                                            \
1341       StgTSO_link(W_[blocked_queue_tl]) = tso;          \
1342     }                                                   \
1343     W_[blocked_queue_tl] = tso;
1344
1345 waitReadzh_fast
1346 {
1347     /* args: R1 */
1348 #ifdef THREADED_RTS
1349     foreign "C" barf("waitRead# on threaded RTS");
1350 #endif
1351
1352     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1353     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1354     StgTSO_block_info(CurrentTSO) = R1;
1355     // No locking - we're not going to use this interface in the
1356     // threaded RTS anyway.
1357     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1358     jump stg_block_noregs;
1359 }
1360
1361 waitWritezh_fast
1362 {
1363     /* args: R1 */
1364 #ifdef THREADED_RTS
1365     foreign "C" barf("waitWrite# on threaded RTS");
1366 #endif
1367
1368     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1369     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1370     StgTSO_block_info(CurrentTSO) = R1;
1371     // No locking - we're not going to use this interface in the
1372     // threaded RTS anyway.
1373     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1374     jump stg_block_noregs;
1375 }
1376
1377
1378 STRING(stg_delayzh_malloc_str, "delayzh_fast")
1379 delayzh_fast
1380 {
1381 #ifdef mingw32_TARGET_OS
1382     W_ ares;
1383     CInt reqID;
1384 #else
1385     W_ t, prev, target;
1386 #endif
1387
1388 #ifdef THREADED_RTS
1389     foreign "C" barf("delay# on threaded RTS");
1390 #endif
1391
1392     /* args: R1 (microsecond delay amount) */
1393     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1394     StgTSO_why_blocked(CurrentTSO) = BlockedOnDelay::I16;
1395
1396 #ifdef mingw32_TARGET_OS
1397
1398     /* could probably allocate this on the heap instead */
1399     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1400                                             stg_delayzh_malloc_str);
1401     reqID = foreign "C" addDelayRequest(R1);
1402     StgAsyncIOResult_reqID(ares)   = reqID;
1403     StgAsyncIOResult_len(ares)     = 0;
1404     StgAsyncIOResult_errCode(ares) = 0;
1405     StgTSO_block_info(CurrentTSO)  = ares;
1406
1407     /* Having all async-blocked threads reside on the blocked_queue
1408      * simplifies matters, so change the status to OnDoProc put the
1409      * delayed thread on the blocked_queue.
1410      */
1411     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1412     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1413     jump stg_block_async_void;
1414
1415 #else
1416
1417     W_ time;
1418     time = foreign "C" getourtimeofday();
1419     target = (R1 / (TICK_MILLISECS*1000)) + time;
1420     StgTSO_block_info(CurrentTSO) = target;
1421
1422     /* Insert the new thread in the sleeping queue. */
1423     prev = NULL;
1424     t = W_[sleeping_queue];
1425 while:
1426     if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) {
1427         prev = t;
1428         t = StgTSO_link(t);
1429         goto while;
1430     }
1431
1432     StgTSO_link(CurrentTSO) = t;
1433     if (prev == NULL) {
1434         W_[sleeping_queue] = CurrentTSO;
1435     } else {
1436         StgTSO_link(prev) = CurrentTSO;
1437     }
1438     jump stg_block_noregs;
1439 #endif
1440 }
1441
1442
1443 #ifdef mingw32_TARGET_OS
1444 STRING(stg_asyncReadzh_malloc_str, "asyncReadzh_fast")
1445 asyncReadzh_fast
1446 {
1447     W_ ares;
1448     CInt reqID;
1449
1450 #ifdef THREADED_RTS
1451     foreign "C" barf("asyncRead# on threaded RTS");
1452 #endif
1453
1454     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1455     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1456     StgTSO_why_blocked(CurrentTSO) = BlockedOnRead::I16;
1457
1458     /* could probably allocate this on the heap instead */
1459     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1460                                             stg_asyncReadzh_malloc_str);
1461     reqID = foreign "C" addIORequest(R1, 0/*FALSE*/,R2,R3,R4 "ptr");
1462     StgAsyncIOResult_reqID(ares)   = reqID;
1463     StgAsyncIOResult_len(ares)     = 0;
1464     StgAsyncIOResult_errCode(ares) = 0;
1465     StgTSO_block_info(CurrentTSO)  = ares;
1466     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1467     jump stg_block_async;
1468 }
1469
1470 STRING(stg_asyncWritezh_malloc_str, "asyncWritezh_fast")
1471 asyncWritezh_fast
1472 {
1473     W_ ares;
1474     CInt reqID;
1475
1476 #ifdef THREADED_RTS
1477     foreign "C" barf("asyncWrite# on threaded RTS");
1478 #endif
1479
1480     /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */
1481     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1482     StgTSO_why_blocked(CurrentTSO) = BlockedOnWrite::I16;
1483
1484     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1485                                             stg_asyncWritezh_malloc_str);
1486     reqID = foreign "C" addIORequest(R1, 1/*TRUE*/,R2,R3,R4 "ptr");
1487
1488     StgAsyncIOResult_reqID(ares)   = reqID;
1489     StgAsyncIOResult_len(ares)     = 0;
1490     StgAsyncIOResult_errCode(ares) = 0;
1491     StgTSO_block_info(CurrentTSO)  = ares;
1492     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1493     jump stg_block_async;
1494 }
1495
1496 STRING(stg_asyncDoProczh_malloc_str, "asyncDoProczh_fast")
1497 asyncDoProczh_fast
1498 {
1499     W_ ares;
1500     CInt reqID;
1501
1502     /* args: R1 = proc, R2 = param */
1503     ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16);
1504     StgTSO_why_blocked(CurrentTSO) = BlockedOnDoProc::I16;
1505
1506     /* could probably allocate this on the heap instead */
1507     "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
1508                                             stg_asyncDoProczh_malloc_str);
1509     reqID = foreign "C" addDoProcRequest(R1 "ptr",R2 "ptr");
1510     StgAsyncIOResult_reqID(ares)   = reqID;
1511     StgAsyncIOResult_len(ares)     = 0;
1512     StgAsyncIOResult_errCode(ares) = 0;
1513     StgTSO_block_info(CurrentTSO) = ares;
1514     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1515     jump stg_block_async;
1516 }
1517 #endif
1518
1519 /* -----------------------------------------------------------------------------
1520   ** temporary **
1521
1522    classes CCallable and CReturnable don't really exist, but the
1523    compiler insists on generating dictionaries containing references
1524    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
1525    for these.  Some C compilers can't cope with zero-length static arrays,
1526    so we have to make these one element long.
1527   --------------------------------------------------------------------------- */
1528
1529 section "rodata" {
1530   GHC_ZCCCallable_static_info:   W_ 0;
1531 }
1532
1533 section "rodata" {
1534   GHC_ZCCReturnable_static_info: W_ 0;
1535 }