ghc/rts/PrimOps.hc

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