ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.21 1999/03/05 10:21:27 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Primitive functions / data
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11
  12 #ifdef COMPILER
  13
  14 #include "RtsFlags.h"
  15 #include "StgStartup.h"
  16 #include "SchedAPI.h"
  17 #include "Schedule.h"
  18 #include "RtsUtils.h"
  19 #include "Storage.h"
  20 #include "BlockAlloc.h" /* tmp */
  21 #include "StablePriv.h"
  22
  23 /* ** temporary **
  24
  25    classes CCallable and CReturnable don't really exist, but the
  26    compiler insists on generating dictionaries containing references
  27    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
  28    for these.
  29 */
  30
  31 W_ GHC_ZCCCallable_static_info[0];
  32 W_ GHC_ZCCReturnable_static_info[0];
  33
  34
  35 /* -----------------------------------------------------------------------------
  36    Macros for Hand-written primitives.
  37    -------------------------------------------------------------------------- */
  38
  39 /*
  40  * Horrible macros for returning unboxed tuples.
  41  *
  42  * How an unboxed tuple is returned depends on two factors:
  43  *    - the number of real registers we have available
  44  *    - the boxedness of the returned fields.
  45  *
  46  * To return an unboxed tuple from a primitive operation, we have macros
  47  * RET_<layout> where <layout> describes the boxedness of each field of the
  48  * unboxed tuple:  N indicates a non-pointer field, and P indicates a pointer.
  49  *
  50  * We only define the cases actually used, to avoid having too much
  51  * garbage in this section.  Warning: any bugs in here will be hard to
  52  * track down.
  53  */
  54
  55 /*------ All Regs available */
  56 #ifdef REG_R8
  57 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  58 # define RET_N(a)     RET_P(a)
  59
  60 # define RET_PP(a,b)  R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
  61 # define RET_NN(a,b)  RET_PP(a,b)
  62 # define RET_NP(a,b)  RET_PP(a,b)
  63
  64 # define RET_PPP(a,b,c) \
  65         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
  66 # define RET_NNP(a,b,c) RET_PPP(a,b,c)
  67
  68 # define RET_NNNP(a,b,c,d) \
  69         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
  70         JMP_(ENTRY_CODE(Sp[0]));
  71
  72 # define RET_NPNP(a,b,c,d) \
  73         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
  74         JMP_(ENTRY_CODE(Sp[0]));
  75
  76 # define RET_NNPNNP(a,b,c,d,e,f) \
  77         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
  78         R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
  79         JMP_(ENTRY_CODE(Sp[0]));
  80
  81 #else
  82
  83 #if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
  84     defined(REG_R4) || defined(REG_R3) || defined(REG_R2)
  85 # error RET_n macros not defined for this setup.
  86 #else
  87
  88 /*------ 1 Register available */
  89 #ifdef REG_R1
  90 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  91 # define RET_N(a)     RET_P(a)
  92
  93 # define RET_PP(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
  94                        JMP_(ENTRY_CODE(Sp[1]));
  95 # define RET_NN(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
  96                        JMP_(ENTRY_CODE(Sp[2]));
  97 # define RET_NP(a,b)   RET_PP(a,b)
  98
  99 # define RET_PPP(a,b,c) \
 100         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
 101         JMP_(ENTRY_CODE(Sp[2]));
 102 # define RET_NNP(a,b,c) \
 103         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
 104         JMP_(ENTRY_CODE(Sp[3]));
 105
 106 # define RET_NNNP(a,b,c,d)                      \
 107         R1.w = (W_)(a);                         \
 108     /*  Sp[-5] = ARGTAG(1); */                  \
 109         Sp[-4] = (W_)(b);                       \
 110     /*  Sp[-3] = ARGTAG(1); */                  \
 111         Sp[-2] = (W_)(c);                       \
 112         Sp[-1] = (W_)(d);                       \
 113         Sp -= 5;                                \
 114         JMP_(ENTRY_CODE(Sp[5]));
 115
 116 # define RET_NPNP(a,b,c,d)                      \
 117         R1.w = (W_)(a);                         \
 118         Sp[-4] = (W_)(b);                       \
 119     /*  Sp[-3] = ARGTAG(1); */                  \
 120         Sp[-2] = (W_)(c);                       \
 121         Sp[-1] = (W_)(d);                       \
 122         Sp -= 4;                                \
 123         JMP_(ENTRY_CODE(Sp[4]));
 124
 125 # define RET_NNPNNP(a,b,c,d,e,f)                \
 126         R1.w = (W_)(a);                         \
 127         Sp[-1] = (W_)(f);                       \
 128         Sp[-2] = (W_)(e);                       \
 129         /* Sp[-3] = ARGTAG(1); */               \
 130         Sp[-4] = (W_)(d);                       \
 131         /* Sp[-5] = ARGTAG(1); */               \
 132         Sp[-6] = (W_)(c);                       \
 133         Sp[-7] = (W_)(b);                       \
 134         /* Sp[-8] = ARGTAG(1); */               \
 135         Sp -= 8;                                \
 136         JMP_(ENTRY_CODE(Sp[8]));
 137
 138 #else /* 0 Regs available */
 139
 140 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
 141 #define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
 142 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 143
 144 /* Here's how to construct these macros:
 145  *
 146  *   N = number of N's in the name;
 147  *   P = number of P's in the name;
 148  *   s = N * 2 + P;
 149  *   while (nonNull(name)) {
 150  *     if (nextChar == 'P') {
 151  *       PUSH_P(s,_);
 152  *       s -= 1;
 153  *     } else {
 154  *       PUSH_N(s,_);
 155  *       s -= 2
 156  *     }
 157  *   }
 158  *   PUSHED(N * 2 + P);
 159  */
 160
 161 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 162 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 163
 164 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 165 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 166 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 167
 168 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 169 # define RET_NNP(a,b,c) PUSH_N(6,a); PUSH_N(4,b); PUSH_N(2,c); PUSHED(6)
 170
 171 # define RET_NNNP(a,b,c,d) PUSH_N(7,a); PUSH_N(5,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(7)
 172 # define RET_NPNP(a,b,c,d) PUSH_N(6,a); PUSH_P(4,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(6)
 173 # define RET_NNPNNP(a,b,c,d,e,f) PUSH_N(10,a); PUSH_N(8,b); PUSH_P(6,c); PUSH_N(5,d); PUSH_N(3,e); PUSH_P(1,f); PUSHED(10)
 174
 175 #endif
 176
 177 #endif
 178 #endif
 179
 180 /*-----------------------------------------------------------------------------
 181   Array Primitives
 182
 183   Basically just new*Array - the others are all inline macros.
 184
 185   The size arg is always passed in R1, and the result returned in R1.
 186
 187   The slow entry point is for returning from a heap check, the saved
 188   size argument must be re-loaded from the stack.
 189   -------------------------------------------------------------------------- */
 190
 191 /* for objects that are *less* than the size of a word, make sure we
 192  * round up to the nearest word for the size of the array.
 193  */
 194
 195 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 196
 197 #define newByteArray(ty,scale)                          \
 198  FN_(new##ty##Arrayzh_fast)                             \
 199  {                                                      \
 200    W_ stuff_size, size, n;                              \
 201    StgArrWords* p;                                      \
 202    FB_                                                  \
 203      MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast);           \
 204      n = R1.w;                                          \
 205      stuff_size = BYTES_TO_STGWORDS(n*scale);           \
 206      size = sizeofW(StgArrWords)+ stuff_size;           \
 207      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 208      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 209      SET_HDR(p, &ARR_WORDS_info, CCCS);         \
 210      p->words = stuff_size;                             \
 211      TICK_RET_UNBOXED_TUP(1)                            \
 212      RET_P(p);                                          \
 213    FE_                                                  \
 214  }
 215
 216 newByteArray(Char,   sizeof(C_))
 217 newByteArray(Int,    sizeof(I_));
 218 newByteArray(Word,   sizeof(W_));
 219 newByteArray(Addr,   sizeof(P_));
 220 newByteArray(Float,  sizeof(StgFloat));
 221 newByteArray(Double, sizeof(StgDouble));
 222 newByteArray(StablePtr, sizeof(StgStablePtr));
 223
 224 FN_(newArrayzh_fast)
 225 {
 226   W_ size, n, init;
 227   StgMutArrPtrs* arr;
 228   StgPtr p;
 229   FB_
 230     n = R1.w;
 231
 232     MAYBE_GC(R2_PTR,newArrayzh_fast);
 233
 234     size = sizeofW(StgMutArrPtrs) + n;
 235     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 236     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 237
 238     SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
 239     arr->ptrs = n;
 240
 241     init = R2.w;
 242     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 243          p < (P_)arr + size; p++) {
 244         *p = (W_)init;
 245     }
 246
 247     TICK_RET_UNBOXED_TUP(1);
 248     RET_P(arr);
 249   FE_
 250 }
 251
 252 FN_(newMutVarzh_fast)
 253 {
 254   StgMutVar* mv;
 255   /* Args: R1.p = initialisation value */
 256   FB_
 257
 258   HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 259   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 260   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 261
 262   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 263   SET_HDR(mv,&MUT_VAR_info,CCCS);
 264   mv->var = R1.cl;
 265
 266   TICK_RET_UNBOXED_TUP(1);
 267   RET_P(mv);
 268   FE_
 269 }
 270
 271 /* -----------------------------------------------------------------------------
 272    Foreign Object Primitives
 273
 274    -------------------------------------------------------------------------- */
 275
 276 #ifndef PAR
 277 FN_(makeForeignObjzh_fast)
 278 {
 279   /* R1.p = ptr to foreign object,
 280   */
 281   StgForeignObj *result;
 282   FB_
 283
 284   HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
 285   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 286                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 287   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 288
 289   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 290   SET_HDR(result,&FOREIGN_info,CCCS);
 291   result->data = R1.p;
 292
 293   /* returns (# s#, ForeignObj# #) */
 294   TICK_RET_UNBOXED_TUP(1);
 295   RET_P(result);
 296   FE_
 297 }
 298 #endif
 299
 300 /* These two are out-of-line for the benefit of the NCG */
 301 FN_(unsafeThawArrayzh_fast)
 302 {
 303   FB_
 304   SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
 305   recordMutable((StgMutClosure*)R1.cl);
 306
 307   TICK_RET_UNBOXED_TUP(1);
 308   RET_P(R1.p);
 309   FE_
 310 }
 311
 312 /* -----------------------------------------------------------------------------
 313    Weak Pointer Primitives
 314    -------------------------------------------------------------------------- */
 315
 316 #ifndef PAR
 317
 318 FN_(mkWeakzh_fast)
 319 {
 320   /* R1.p = key
 321      R2.p = value
 322      R3.p = finalizer
 323   */
 324   StgWeak *w;
 325   FB_
 326
 327   HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 328   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 329                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 330   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 331
 332   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 333   SET_HDR(w, &WEAK_info, CCCS);
 334
 335   w->key        = R1.cl;
 336   w->value      = R2.cl;
 337   if (R3.cl) {
 338      w->finalizer  = R3.cl;
 339   } else {
 340      w->finalizer  = &NO_FINALIZER_closure;
 341   }
 342
 343   w->link       = weak_ptr_list;
 344   weak_ptr_list = w;
 345   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 346
 347   TICK_RET_UNBOXED_TUP(1);
 348   RET_P(w);
 349   FE_
 350 }
 351
 352 FN_(finalizzeWeakzh_fast)
 353 {
 354   /* R1.p = weak ptr
 355    */
 356   StgDeadWeak *w;
 357   StgClosure *f;
 358   FB_
 359   TICK_RET_UNBOXED_TUP(0);
 360   w = (StgDeadWeak *)R1.p;
 361
 362   /* already dead? */
 363   if (w->header.info == &DEAD_WEAK_info) {
 364       RET_NP(0,&NO_FINALIZER_closure);
 365   }
 366
 367   /* kill it */
 368   w->header.info = &DEAD_WEAK_info;
 369   f = ((StgWeak *)w)->finalizer;
 370   w->link = ((StgWeak *)w)->link;
 371
 372   /* return the finalizer */
 373   if (f == &NO_FINALIZER_closure) {
 374       RET_NP(0,&NO_FINALIZER_closure);
 375   } else {
 376       RET_NP(1,f);
 377   }
 378   FE_
 379 }
 380
 381 #endif /* !PAR */
 382
 383 /* -----------------------------------------------------------------------------
 384    Arbitrary-precision Integer operations.
 385    -------------------------------------------------------------------------- */
 386
 387 FN_(int2Integerzh_fast)
 388 {
 389    /* arguments: R1 = Int# */
 390
 391    I_ val, s;           /* to avoid aliasing */
 392    StgArrWords* p;      /* address of array result */
 393    FB_
 394
 395    val = R1.i;
 396    HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 397    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 398    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 399
 400    p = stgCast(StgArrWords*,Hp)-1;
 401    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 402
 403    /* mpz_set_si is inlined here, makes things simpler */
 404    if (val < 0) {
 405         s  = -1;
 406         *Hp = -val;
 407    } else if (val > 0) {
 408         s = 1;
 409         *Hp = val;
 410    } else {
 411         s = 0;
 412    }
 413
 414    /* returns (# size  :: Int#,
 415                  data  :: ByteArray#
 416                #)
 417    */
 418    TICK_RET_UNBOXED_TUP(2);
 419    RET_NP(s,p);
 420    FE_
 421 }
 422
 423 FN_(word2Integerzh_fast)
 424 {
 425    /* arguments: R1 = Word# */
 426
 427    W_ val;              /* to avoid aliasing */
 428    I_  s;
 429    StgArrWords* p;      /* address of array result */
 430    FB_
 431
 432    val = R1.w;
 433    HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 434    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 435    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 436
 437    p = stgCast(StgArrWords*,Hp)-1;
 438    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 439
 440    if (val != 0) {
 441         s = 1;
 442         *Hp = val;
 443    } else {
 444         s = 0;
 445    }
 446
 447    /* returns (# size  :: Int#,
 448                  data  :: ByteArray#
 449                #)
 450    */
 451    TICK_RET_UNBOXED_TUP(2);
 452    RET_NP(s,p);
 453    FE_
 454 }
 455
 456 FN_(addr2Integerzh_fast)
 457 {
 458   MP_INT result;
 459   char *str;
 460   FB_
 461
 462   MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
 463
 464   /* args:   R1 :: Addr# */
 465   str = R1.a;
 466
 467   /* Perform the operation */
 468   if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
 469       abort();
 470
 471    /* returns (# size  :: Int#,
 472                  data  :: ByteArray#
 473                #)
 474    */
 475   TICK_RET_UNBOXED_TUP(2);
 476   RET_NP(result._mp_size,
 477           result._mp_d - sizeofW(StgArrWords));
 478   FE_
 479 }
 480
 481 /*
 482  * 'long long' primops for converting to/from Integers.
 483  */
 484
 485 #ifdef SUPPORT_LONG_LONGS
 486
 487 FN_(int64ToIntegerzh_fast)
 488 {
 489    /* arguments: L1 = Int64# */
 490
 491    StgInt64  val; /* to avoid aliasing */
 492    W_ hi;
 493    I_  s, neg, words_needed;
 494    StgArrWords* p;      /* address of array result */
 495    FB_
 496
 497    val = (LI_)L1;
 498    neg = 0;
 499
 500    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 501        words_needed = 2;
 502    } else {
 503        /* minimum is one word */
 504        words_needed = 1;
 505    }
 506    HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 507    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 508    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 509
 510    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
 511    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 512
 513    if ( val < 0LL ) {
 514      neg = 1;
 515      val = -val;
 516    }
 517
 518    hi = (W_)((LW_)val / 0x100000000ULL);
 519
 520    if ( words_needed == 2 )  {
 521       s = 2;
 522       Hp[-1] = (W_)val;
 523       Hp[0] = hi;
 524    } else if ( val != 0 ) {
 525       s = 1;
 526       Hp[0] = (W_)val;
 527    }  else /* val==0 */   {
 528       s = 0;
 529    }
 530    s = ( neg ? -s : s );
 531
 532    /* returns (# size  :: Int#,
 533                  data  :: ByteArray#
 534                #)
 535    */
 536    TICK_RET_UNBOXED_TUP(2);
 537    RET_NP(s,p);
 538    FE_
 539 }
 540
 541 FN_(word64ToIntegerzh_fast)
 542 {
 543    /* arguments: L1 = Word64# */
 544
 545    StgWord64 val; /* to avoid aliasing */
 546    StgWord hi;
 547    I_  s, words_needed;
 548    StgArrWords* p;      /* address of array result */
 549    FB_
 550
 551    val = (LW_)L1;
 552    if ( val >= 0x100000000ULL ) {
 553       words_needed = 2;
 554    } else {
 555       words_needed = 1;
 556    }
 557    HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 558    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 559    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 560
 561    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
 562    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 563
 564    hi = (W_)((LW_)val / 0x100000000ULL);
 565    if ( val >= 0x100000000ULL ) {
 566      s = 2;
 567      Hp[-1] = ((W_)val);
 568      Hp[0]  = (hi);
 569    } else if ( val != 0 )      {
 570       s = 1;
 571       Hp[0] = ((W_)val);
 572    } else /* val==0 */         {
 573       s = 0;
 574    }
 575
 576    /* returns (# size  :: Int#,
 577                  data  :: ByteArray#
 578                #)
 579    */
 580    TICK_RET_UNBOXED_TUP(2);
 581    RET_NP(s,p);
 582    FE_
 583 }
 584
 585
 586 #endif /* HAVE_LONG_LONG */
 587
 588 /* ToDo: this is shockingly inefficient */
 589
 590 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 591 FN_(name)                                                               \
 592 {                                                                       \
 593   MP_INT arg1, arg2, result;                                            \
 594   I_ s1, s2;                                                    \
 595   StgArrWords* d1;                                                      \
 596   StgArrWords* d2;                                                      \
 597   FB_                                                                   \
 598                                                                         \
 599   /* call doYouWantToGC() */                                            \
 600   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 601                                                                         \
 602   d1 = (StgArrWords *)R2.p;                                             \
 603   s1 = R1.i;                                                            \
 604   d2 = (StgArrWords *)R4.p;                                             \
 605   s2 = R3.i;                                                            \
 606                                                                         \
 607   arg1._mp_alloc        = d1->words;                                    \
 608   arg1._mp_size         = (s1);                                         \
 609   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 610   arg2._mp_alloc        = d2->words;                                    \
 611   arg2._mp_size         = (s2);                                         \
 612   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 613                                                                         \
 614   STGCALL1(mpz_init,&result);                                           \
 615                                                                         \
 616   /* Perform the operation */                                           \
 617   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 618                                                                         \
 619   TICK_RET_UNBOXED_TUP(2);                                              \
 620   RET_NP(result._mp_size,                                               \
 621          result._mp_d-sizeofW(StgArrWords));                            \
 622   FE_                                                                   \
 623 }
 624
 625 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 626 FN_(name)                                                               \
 627 {                                                                       \
 628   MP_INT arg1, arg2, result1, result2;                                  \
 629   I_ s1, s2;                                                    \
 630   StgArrWords* d1;                                                      \
 631   StgArrWords* d2;                                                      \
 632   FB_                                                                   \
 633                                                                         \
 634   /* call doYouWantToGC() */                                            \
 635   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 636                                                                         \
 637   d1 = (StgArrWords *)R2.p;                                             \
 638   s1 = R1.i;                                                            \
 639   d2 = (StgArrWords *)R4.p;                                             \
 640   s2 = R3.i;                                                            \
 641                                                                         \
 642   arg1._mp_alloc        = d1->words;                                    \
 643   arg1._mp_size         = (s1);                                         \
 644   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 645   arg2._mp_alloc        = d2->words;                                    \
 646   arg2._mp_size         = (s2);                                         \
 647   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 648                                                                         \
 649   STGCALL1(mpz_init,&result1);                                          \
 650   STGCALL1(mpz_init,&result2);                                          \
 651                                                                         \
 652   /* Perform the operation */                                           \
 653   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 654                                                                         \
 655   TICK_RET_UNBOXED_TUP(4);                                              \
 656   RET_NPNP(result1._mp_size,                                            \
 657            result1._mp_d-sizeofW(StgArrWords),                          \
 658            result2._mp_size,                                            \
 659            result2._mp_d-sizeofW(StgArrWords));                         \
 660   FE_                                                                   \
 661 }
 662
 663 GMP_TAKE2_RET1(plusIntegerzh_fast,  mpz_add);
 664 GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub);
 665 GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul);
 666 GMP_TAKE2_RET1(gcdIntegerzh_fast,   mpz_gcd);
 667
 668 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 669 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 670
 671 #ifndef FLOATS_AS_DOUBLES
 672 FN_(decodeFloatzh_fast)
 673 {
 674   MP_INT mantissa;
 675   I_ exponent;
 676   StgArrWords* p;
 677   StgFloat arg;
 678   FB_
 679
 680   /* arguments: F1 = Float# */
 681   arg = F1;
 682
 683   HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 684   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 685   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 686
 687   /* Be prepared to tell Lennart-coded __decodeFloat    */
 688   /* where mantissa._mp_d can be put (it does not care about the rest) */
 689   p = stgCast(StgArrWords*,Hp)-1;
 690   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 691   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 692
 693   /* Perform the operation */
 694   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 695
 696   /* returns: (Int# (expn), Int#, ByteArray#) */
 697   TICK_RET_UNBOXED_TUP(3);
 698   RET_NNP(exponent,mantissa._mp_size,p);
 699   FE_
 700 }
 701 #endif /* !FLOATS_AS_DOUBLES */
 702
 703 #define DOUBLE_MANTISSA_SIZE (sizeof(StgDouble)/sizeof(W_))
 704 #define ARR_SIZE (sizeof(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 705
 706 FN_(decodeDoublezh_fast)
 707 { MP_INT mantissa;
 708   I_ exponent;
 709   StgDouble arg;
 710   StgArrWords* p;
 711   FB_
 712
 713   /* arguments: D1 = Double# */
 714   arg = D1;
 715
 716   HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 717   TICK_ALLOC_PRIM(sizeof(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 718   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 719
 720   /* Be prepared to tell Lennart-coded __decodeDouble   */
 721   /* where mantissa.d can be put (it does not care about the rest) */
 722   p = stgCast(StgArrWords*,Hp-ARR_SIZE+1);
 723   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 724   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 725
 726   /* Perform the operation */
 727   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 728
 729   /* returns: (Int# (expn), Int#, ByteArray#) */
 730   TICK_RET_UNBOXED_TUP(3);
 731   RET_NNP(exponent,mantissa._mp_size,p);
 732   FE_
 733 }
 734
 735 /* -----------------------------------------------------------------------------
 736  * Concurrency primitives
 737  * -------------------------------------------------------------------------- */
 738
 739 FN_(forkzh_fast)
 740 {
 741   FB_
 742   /* args: R1 = closure to spark */
 743
 744   if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) {
 745
 746     MAYBE_GC(R1_PTR, forkzh_fast);
 747
 748     /* create it right now, return ThreadID in R1 */
 749     R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 750                         RtsFlags.GcFlags.initialStkSize, R1.cl);
 751
 752     /* switch at the earliest opportunity */
 753     context_switch = 1;
 754   }
 755
 756   JMP_(ENTRY_CODE(Sp[0]));
 757   FE_
 758 }
 759
 760 FN_(killThreadzh_fast)
 761 {
 762   FB_
 763   /* args: R1.p = TSO to kill */
 764
 765   /* The thread is dead, but the TSO sticks around for a while.  That's why
 766    * we don't have to explicitly remove it from any queues it might be on.
 767    */
 768   STGCALL1(deleteThread, (StgTSO *)R1.p);
 769
 770   /* We might have killed ourselves.  In which case, better return to the
 771    * scheduler...
 772    */
 773   if ((StgTSO *)R1.p == CurrentTSO) {
 774         JMP_(stg_stop_thread_entry); /* leave semi-gracefully */
 775   }
 776
 777   JMP_(ENTRY_CODE(Sp[0]));
 778   FE_
 779 }
 780
 781 FN_(newMVarzh_fast)
 782 {
 783   StgMVar *mvar;
 784
 785   FB_
 786   /* args: none */
 787
 788   HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 789   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 790                   1, 0);
 791   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 792
 793   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 794   SET_INFO(mvar,&EMPTY_MVAR_info);
 795   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 796   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 797
 798   TICK_RET_UNBOXED_TUP(1);
 799   RET_P(mvar);
 800   FE_
 801 }
 802
 803 FN_(takeMVarzh_fast)
 804 {
 805   StgMVar *mvar;
 806   StgClosure *val;
 807
 808   FB_
 809   /* args: R1 = MVar closure */
 810
 811   mvar = (StgMVar *)R1.p;
 812
 813   /* If the MVar is empty, put ourselves on its blocking queue,
 814    * and wait until we're woken up.
 815    */
 816   if (GET_INFO(mvar) != &FULL_MVAR_info) {
 817     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 818       mvar->head = CurrentTSO;
 819     } else {
 820       mvar->tail->link = CurrentTSO;
 821     }
 822     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 823     mvar->tail = CurrentTSO;
 824
 825     BLOCK(R1_PTR, takeMVarzh_fast);
 826   }
 827
 828   SET_INFO(mvar,&EMPTY_MVAR_info);
 829   val = mvar->value;
 830   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 831
 832   TICK_RET_UNBOXED_TUP(1);
 833   RET_P(val);
 834   FE_
 835 }
 836
 837 FN_(putMVarzh_fast)
 838 {
 839   StgMVar *mvar;
 840   StgTSO *tso;
 841
 842   FB_
 843   /* args: R1 = MVar, R2 = value */
 844
 845   mvar = (StgMVar *)R1.p;
 846   if (GET_INFO(mvar) == &FULL_MVAR_info) {
 847     fflush(stdout);
 848     fprintf(stderr, "putMVar#: MVar already full.\n");
 849     stg_exit(EXIT_FAILURE);
 850   }
 851
 852   SET_INFO(mvar,&FULL_MVAR_info);
 853   mvar->value = R2.cl;
 854
 855   /* wake up the first thread on the queue,
 856    * it will continue with the takeMVar operation and mark the MVar
 857    * empty again.
 858    */
 859   tso = mvar->head;
 860   if (tso != (StgTSO *)&END_TSO_QUEUE_closure) {
 861     PUSH_ON_RUN_QUEUE(tso);
 862     mvar->head = tso->link;
 863     tso->link = (StgTSO *)&END_TSO_QUEUE_closure;
 864     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 865       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 866     }
 867   }
 868
 869   /* ToDo: yield here for better communication performance? */
 870   JMP_(ENTRY_CODE(Sp[0]));
 871   FE_
 872 }
 873
 874 /* -----------------------------------------------------------------------------
 875    Stable pointer primitives
 876    -------------------------------------------------------------------------  */
 877
 878 FN_(makeStableNamezh_fast)
 879 {
 880   StgWord index;
 881   StgStableName *sn_obj;
 882   FB_
 883
 884   HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 885   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 886                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
 887   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
 888
 889   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 890
 891   /* Is there already a StableName for this heap object? */
 892   if (stable_ptr_table[index].sn_obj == NULL) {
 893     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
 894     sn_obj->header.info = &STABLE_NAME_info;
 895     sn_obj->sn = index;
 896     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
 897   } else {
 898     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
 899   }
 900
 901   TICK_RET_UNBOXED_TUP(1);
 902   RET_P(sn_obj);
 903 }
 904
 905 #endif /* COMPILER */
 906