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