ghc/rts/PrimOps.hc

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