ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.10 1999/02/01 18:05:34 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 "StablePriv.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 *)RET_STGCALL1(P_,allocate,size); \
 199      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 200      SET_HDR(p, &MUT_ARR_WORDS_info, CCCS);             \
 201      p->words = stuff_size;                             \
 202      TICK_RET_UNBOXED_TUP(1)                            \
 203      RET_P(p);                                          \
 204    FE_                                                  \
 205  }
 206
 207 newByteArray(Char,   sizeof(C_))
 208 newByteArray(Int,    sizeof(I_));
 209 newByteArray(Word,   sizeof(W_));
 210 newByteArray(Addr,   sizeof(P_));
 211 newByteArray(Float,  sizeof(StgFloat));
 212 newByteArray(Double, sizeof(StgDouble));
 213 newByteArray(StablePtr, sizeof(StgStablePtr));
 214
 215 FN_(newArrayzh_fast)
 216 {
 217   W_ size, n, init;
 218   StgMutArrPtrs* arr;
 219   StgPtr p;
 220   FB_
 221     n = R1.w;
 222
 223     MAYBE_GC(R2_PTR,newArrayzh_fast);
 224
 225     size = sizeofW(StgMutArrPtrs) + n;
 226     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 227     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 228
 229     SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
 230     arr->ptrs = n;
 231
 232     init = R2.w;
 233     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 234          p < (P_)arr + size; p++) {
 235         *p = (W_)init;
 236     }
 237
 238     TICK_RET_UNBOXED_TUP(1);
 239     RET_P(arr);
 240   FE_
 241 }
 242
 243 FN_(newMutVarzh_fast)
 244 {
 245   StgMutVar* mv;
 246   /* Args: R1.p = initialisation value */
 247   FB_
 248
 249   HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 250   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 251   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 252
 253   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 254   SET_HDR(mv,&MUT_VAR_info,CCCS);
 255   mv->var = R1.cl;
 256
 257   TICK_RET_UNBOXED_TUP(1);
 258   RET_P(mv);
 259   FE_
 260 }
 261
 262 /* -----------------------------------------------------------------------------
 263    Foreign Object Primitives
 264
 265    -------------------------------------------------------------------------- */
 266
 267 #ifndef PAR
 268 FN_(makeForeignObjzh_fast)
 269 {
 270   /* R1.p = ptr to foreign object,
 271   */
 272   StgForeignObj *result;
 273   FB_
 274
 275   HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
 276   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 277                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 278   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 279
 280   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 281   SET_HDR(result,&FOREIGN_info,CCCS);
 282   result->data = R1.p;
 283
 284   /* returns (# s#, ForeignObj# #) */
 285   TICK_RET_UNBOXED_TUP(1);
 286   RET_P(result);
 287   FE_
 288 }
 289 #endif
 290
 291 /* -----------------------------------------------------------------------------
 292    Weak Pointer Primitives
 293    -------------------------------------------------------------------------- */
 294
 295 #ifndef PAR
 296
 297 FN_(mkWeakzh_fast)
 298 {
 299   /* R1.p = key
 300      R2.p = value
 301      R3.p = finaliser
 302   */
 303   StgWeak *w;
 304   FB_
 305
 306   HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 307   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 308                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 309   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 310
 311   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 312   SET_HDR(w, &WEAK_info, CCCS);
 313
 314   w->key        = R1.cl;
 315   w->value      = R2.cl;
 316   if (R3.cl) {
 317      w->finaliser  = R3.cl;
 318   } else
 319      w->finaliser  = &NO_FINALISER_closure;
 320   }
 321
 322   w->link       = weak_ptr_list;
 323   weak_ptr_list = w;
 324   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 325
 326   TICK_RET_UNBOXED_TUP(1);
 327   RET_P(w);
 328   FE_
 329 }
 330
 331 FN_(finaliseWeakzh_fast)
 332 {
 333   /* R1.p = weak ptr
 334    */
 335   StgWeak *w;
 336   FB_
 337   TICK_RET_UNBOXED_TUP(0);
 338   w = (StgWeak *)R1.p;
 339
 340   if (w->finaliser != &NO_FINALISER_info) {
 341 #ifdef INTERPRETER
 342       STGCALL2(StgTSO *, createGenThread,
 343                 RtsFlags.GcFlags.initialStkSize, w->finaliser);
 344 #else
 345       STGCALL2(StgTSO *, createIOThread,
 346                 RtsFlags.GcFlags.initialStkSize, w->finaliser);
 347 #endif
 348   }
 349   w->header.info = &DEAD_WEAK_info;
 350
 351   JMP_(ENTRY_CODE(Sp[0]));
 352   FE_
 353 }
 354
 355 #endif /* !PAR */
 356
 357 /* -----------------------------------------------------------------------------
 358    Arbitrary-precision Integer operations.
 359    -------------------------------------------------------------------------- */
 360
 361 FN_(int2Integerzh_fast)
 362 {
 363    /* arguments: R1 = Int# */
 364
 365    I_ val, s;           /* to avoid aliasing */
 366    StgArrWords* p;      /* address of array result */
 367    FB_
 368
 369    val = R1.i;
 370    HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 371    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 372    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 373
 374    p = stgCast(StgArrWords*,Hp)-1;
 375    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 376
 377    /* mpz_set_si is inlined here, makes things simpler */
 378    if (val < 0) {
 379         s  = -1;
 380         *Hp = -val;
 381    } else if (val > 0) {
 382         s = 1;
 383         *Hp = val;
 384    } else {
 385         s = 0;
 386    }
 387
 388    /* returns (# alloc :: Int#,
 389                  size  :: Int#,
 390                  data  :: ByteArray#
 391                #)
 392    */
 393    TICK_RET_UNBOXED_TUP(3);
 394    RET_NNP(1,s,p);
 395    FE_
 396 }
 397
 398 FN_(word2Integerzh_fast)
 399 {
 400    /* arguments: R1 = Word# */
 401
 402    W_ val;              /* to avoid aliasing */
 403    I_  s;
 404    StgArrWords* p;      /* address of array result */
 405    FB_
 406
 407    val = R1.w;
 408    HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 409    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 410    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 411
 412    p = stgCast(StgArrWords*,Hp)-1;
 413    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 414
 415    if (val != 0) {
 416         s = 1;
 417         *Hp = val;
 418    } else {
 419         s = 0;
 420    }
 421
 422    /* returns (# alloc :: Int#,
 423                  size  :: Int#,
 424                  data  :: ByteArray#
 425                #)
 426    */
 427   TICK_RET_UNBOXED_TUP(3);
 428    RET_NNP(1,s,p);
 429    FE_
 430 }
 431
 432 FN_(addr2Integerzh_fast)
 433 {
 434   MP_INT result;
 435   char *str;
 436   FB_
 437
 438   MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
 439
 440   /* args:   R1 :: Addr# */
 441   str = R1.a;
 442
 443   /* Perform the operation */
 444   if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
 445       abort();
 446
 447   TICK_RET_UNBOXED_TUP(3);
 448   RET_NNP(result._mp_alloc, result._mp_size,
 449           result._mp_d - sizeofW(StgArrWords));
 450   FE_
 451 }
 452
 453 /*
 454  * 'long long' primops for converting to/from Integers.
 455  */
 456
 457 #ifdef SUPPORT_LONG_LONGS
 458
 459 FN_(int64ToIntegerzh_fast)
 460 {
 461    /* arguments: L1 = Int64# */
 462
 463    StgInt64  val; /* to avoid aliasing */
 464    W_ hi;
 465    I_  s,a, neg, words_needed;
 466    StgArrWords* p;      /* address of array result */
 467    FB_
 468
 469    val = (LI_)L1;
 470    neg = 0;
 471
 472    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 473        words_needed = 2;
 474    } else {
 475        /* minimum is one word */
 476        words_needed = 1;
 477    }
 478    HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 479    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 480    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 481
 482    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
 483    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 484
 485    a = words_needed;
 486
 487    if ( val < 0LL ) {
 488      neg = 1;
 489      val = -val;
 490    }
 491
 492    hi = (W_)((LW_)val / 0x100000000ULL);
 493
 494    if ( a == 2 )  {
 495       s = 2;
 496       Hp[-1] = (W_)val;
 497       Hp[0] = hi;
 498    } else if ( val != 0 ) {
 499       s = 1;
 500       Hp[0] = (W_)val;
 501    }  else /* val==0 */   {
 502       s = 0;
 503    }
 504    s = ( neg ? -s : s );
 505
 506    /* returns (# alloc :: Int#,
 507                  size  :: Int#,
 508                  data  :: ByteArray#
 509                #)
 510    */
 511    TICK_RET_UNBOXED_TUP(3);
 512    RET_NNP(a,s,p);
 513    FE_
 514 }
 515
 516 FN_(word64ToIntegerzh_fast)
 517 {
 518    /* arguments: L1 = Word64# */
 519
 520    StgNat64 val; /* to avoid aliasing */
 521    StgWord hi;
 522    I_  s,a,words_needed;
 523    StgArrWords* p;      /* address of array result */
 524    FB_
 525
 526    val = (LW_)L1;
 527    if ( val >= 0x100000000ULL ) {
 528       words_needed = 2;
 529    } else {
 530       words_needed = 1;
 531    }
 532    HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 533    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 534    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 535
 536    p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
 537    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 538
 539    a = words_needed;
 540
 541    hi = (W_)((LW_)val / 0x100000000ULL);
 542    if ( val >= 0x100000000ULL ) {
 543      s = 2;
 544      Hp[-1] = ((W_)val);
 545      Hp[0]  = (hi);
 546    } else if ( val != 0 )      {
 547       s = 1;
 548       Hp[0] = ((W_)val);
 549    } else /* val==0 */         {
 550       s = 0;
 551    }
 552
 553    /* returns (# alloc :: Int#,
 554                  size  :: Int#,
 555                  data  :: ByteArray#
 556                #)
 557    */
 558    TICK_RET_UNBOXED_TUP(3);
 559    RET_NNP(a,s,p);
 560    FE_
 561 }
 562
 563
 564 #endif /* HAVE_LONG_LONG */
 565
 566 /* ToDo: this is shockingly inefficient */
 567
 568 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 569 FN_(name)                                                               \
 570 {                                                                       \
 571   MP_INT arg1, arg2, result;                                            \
 572   I_ a1, s1, a2, s2;                                                    \
 573   StgArrWords* d1;                                                      \
 574   StgArrWords* d2;                                                      \
 575   FB_                                                                   \
 576                                                                         \
 577   /* call doYouWantToGC() */                                            \
 578   MAYBE_GC(R3_PTR | R6_PTR, name);                                      \
 579                                                                         \
 580   a1 = R1.i;                                                            \
 581   s1 = R2.i;                                                            \
 582   d1 = stgCast(StgArrWords*,R3.p);                                      \
 583   a2 = R4.i;                                                            \
 584   s2 = R5.i;                                                            \
 585   d2 = stgCast(StgArrWords*,R6.p);                                      \
 586                                                                         \
 587   arg1._mp_alloc        = (a1);                                         \
 588   arg1._mp_size         = (s1);                                         \
 589   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 590   arg2._mp_alloc        = (a2);                                         \
 591   arg2._mp_size         = (s2);                                         \
 592   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 593                                                                         \
 594   STGCALL1(mpz_init,&result);                                           \
 595                                                                         \
 596   /* Perform the operation */                                           \
 597   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 598                                                                         \
 599   TICK_RET_UNBOXED_TUP(3);                                              \
 600   RET_NNP(result._mp_alloc,                                             \
 601           result._mp_size,                                              \
 602           result._mp_d-sizeofW(StgArrWords));                           \
 603   FE_                                                                   \
 604 }
 605
 606 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 607 FN_(name)                                                               \
 608 {                                                                       \
 609   MP_INT arg1, arg2, result1, result2;                                  \
 610   I_ a1, s1, a2, s2;                                                    \
 611   StgArrWords* d1;                                                      \
 612   StgArrWords* d2;                                                      \
 613   FB_                                                                   \
 614                                                                         \
 615   /* call doYouWantToGC() */                                            \
 616   MAYBE_GC(R3_PTR | R6_PTR, name);                                      \
 617                                                                         \
 618   a1 = R1.i;                                                            \
 619   s1 = R2.i;                                                            \
 620   d1 = stgCast(StgArrWords*,R3.p);                                      \
 621   a2 = R4.i;                                                            \
 622   s2 = R5.i;                                                            \
 623   d2 = stgCast(StgArrWords*,R6.p);                                      \
 624                                                                         \
 625   arg1._mp_alloc        = (a1);                                         \
 626   arg1._mp_size         = (s1);                                         \
 627   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 628   arg2._mp_alloc        = (a2);                                         \
 629   arg2._mp_size         = (s2);                                         \
 630   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 631                                                                         \
 632   STGCALL1(mpz_init,&result1);                                          \
 633   STGCALL1(mpz_init,&result2);                                          \
 634                                                                         \
 635   /* Perform the operation */                                           \
 636   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 637                                                                         \
 638   TICK_RET_UNBOXED_TUP(6);                                              \
 639   RET_NNPNNP(result1._mp_alloc,                                         \
 640              result1._mp_size,                                          \
 641              result1._mp_d-sizeofW(StgArrWords),                        \
 642              result2._mp_alloc,                                         \
 643              result2._mp_size,                                          \
 644              result2._mp_d-sizeofW(StgArrWords));                       \
 645   FE_                                                                   \
 646 }
 647
 648 GMP_TAKE2_RET1(plusIntegerzh_fast,  mpz_add);
 649 GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub);
 650 GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul);
 651 GMP_TAKE2_RET1(gcdIntegerzh_fast,   mpz_gcd);
 652
 653 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 654 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 655
 656 #ifndef FLOATS_AS_DOUBLES
 657 FN_(decodeFloatzh_fast)
 658 {
 659   MP_INT mantissa;
 660   I_ exponent;
 661   StgArrWords* p;
 662   StgFloat arg;
 663   FB_
 664
 665   /* arguments: F1 = Float# */
 666   arg = F1;
 667
 668   HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 669   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 670   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 671
 672   /* Be prepared to tell Lennart-coded __decodeFloat    */
 673   /* where mantissa._mp_d can be put (it does not care about the rest) */
 674   p = stgCast(StgArrWords*,Hp)-1;
 675   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 676   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 677
 678   /* Perform the operation */
 679   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 680
 681   /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
 682   TICK_RET_UNBOXED_TUP(4);
 683   RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
 684   FE_
 685 }
 686 #endif /* !FLOATS_AS_DOUBLES */
 687
 688 #define DOUBLE_MANTISSA_SIZE (sizeof(StgDouble)/sizeof(W_))
 689 #define ARR_SIZE (sizeof(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 690
 691 FN_(decodeDoublezh_fast)
 692 { MP_INT mantissa;
 693   I_ exponent;
 694   StgDouble arg;
 695   StgArrWords* p;
 696   FB_
 697
 698   /* arguments: D1 = Double# */
 699   arg = D1;
 700
 701   HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 702   TICK_ALLOC_PRIM(sizeof(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 703   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 704
 705   /* Be prepared to tell Lennart-coded __decodeDouble   */
 706   /* where mantissa.d can be put (it does not care about the rest) */
 707   p = stgCast(StgArrWords*,Hp-ARR_SIZE+1);
 708   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 709   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 710
 711   /* Perform the operation */
 712   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 713
 714   /* returns: (R1 = Int# (expn), R2 = Int#, R3 = Int#, R4 = ByteArray#) */
 715   TICK_RET_UNBOXED_TUP(4);
 716   RET_NNNP(exponent,mantissa._mp_alloc,mantissa._mp_size,p);
 717   FE_
 718 }
 719
 720 /* -----------------------------------------------------------------------------
 721  * Concurrency primitives
 722  * -------------------------------------------------------------------------- */
 723
 724 FN_(forkzh_fast)
 725 {
 726   FB_
 727   /* args: R1 = closure to spark */
 728
 729   if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) {
 730
 731     MAYBE_GC(R1_PTR, forkzh_fast);
 732
 733     /* create it right now, return ThreadID in R1 */
 734     R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 735                         RtsFlags.GcFlags.initialStkSize, R1.cl);
 736
 737     /* switch at the earliest opportunity */
 738     context_switch = 1;
 739   }
 740
 741   JMP_(ENTRY_CODE(Sp[0]));
 742   FE_
 743 }
 744
 745 FN_(killThreadzh_fast)
 746 {
 747   FB_
 748   /* args: R1.p = TSO to kill */
 749
 750   /* The thread is dead, but the TSO sticks around for a while.  That's why
 751    * we don't have to explicitly remove it from any queues it might be on.
 752    */
 753   STGCALL1(deleteThread, (StgTSO *)R1.p);
 754
 755   /* We might have killed ourselves.  In which case, better return to the
 756    * scheduler...
 757    */
 758   if ((StgTSO *)R1.p == CurrentTSO) {
 759         JMP_(stg_stop_thread_entry); /* leave semi-gracefully */
 760   }
 761
 762   JMP_(ENTRY_CODE(Sp[0]));
 763   FE_
 764 }
 765
 766 FN_(newMVarzh_fast)
 767 {
 768   StgMVar *mvar;
 769
 770   FB_
 771   /* args: none */
 772
 773   HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 774   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 775                   1, 0);
 776   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 777
 778   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 779   SET_INFO(mvar,&EMPTY_MVAR_info);
 780   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 781   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 782
 783   TICK_RET_UNBOXED_TUP(1);
 784   RET_P(mvar);
 785   FE_
 786 }
 787
 788 FN_(takeMVarzh_fast)
 789 {
 790   StgMVar *mvar;
 791   StgClosure *val;
 792
 793   FB_
 794   /* args: R1 = MVar closure */
 795
 796   mvar = (StgMVar *)R1.p;
 797
 798   /* If the MVar is empty, put ourselves on its blocking queue,
 799    * and wait until we're woken up.
 800    */
 801   if (GET_INFO(mvar) != &FULL_MVAR_info) {
 802     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 803       mvar->head = CurrentTSO;
 804     } else {
 805       mvar->tail->link = CurrentTSO;
 806     }
 807     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 808     mvar->tail = CurrentTSO;
 809
 810     BLOCK(R1_PTR, takeMVarzh_fast);
 811   }
 812
 813   SET_INFO(mvar,&EMPTY_MVAR_info);
 814   val = mvar->value;
 815   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 816
 817   TICK_RET_UNBOXED_TUP(1);
 818   RET_P(val);
 819   FE_
 820 }
 821
 822 FN_(putMVarzh_fast)
 823 {
 824   StgMVar *mvar;
 825   StgTSO *tso;
 826
 827   FB_
 828   /* args: R1 = MVar, R2 = value */
 829
 830   mvar = (StgMVar *)R1.p;
 831   if (GET_INFO(mvar) == &FULL_MVAR_info) {
 832     fflush(stdout);
 833     fprintf(stderr, "putMVar#: MVar already full.\n");
 834     stg_exit(EXIT_FAILURE);
 835   }
 836
 837   SET_INFO(mvar,&FULL_MVAR_info);
 838   mvar->value = R2.cl;
 839
 840   /* wake up the first thread on the queue,
 841    * it will continue with the takeMVar operation and mark the MVar
 842    * empty again.
 843    */
 844   tso = mvar->head;
 845   if (tso != (StgTSO *)&END_TSO_QUEUE_closure) {
 846     PUSH_ON_RUN_QUEUE(tso);
 847     mvar->head = tso->link;
 848     tso->link = (StgTSO *)&END_TSO_QUEUE_closure;
 849     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 850       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 851     }
 852   }
 853
 854   /* ToDo: yield here for better communication performance? */
 855   JMP_(ENTRY_CODE(Sp[0]));
 856   FE_
 857 }
 858
 859 /* -----------------------------------------------------------------------------
 860    Stable pointer primitives
 861    -------------------------------------------------------------------------  */
 862
 863 FN_(makeStableNamezh_fast)
 864 {
 865   StgWord index;
 866   StgStableName *sn_obj;
 867   FB_
 868
 869   HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 870   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 871                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
 872   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
 873
 874   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 875
 876   sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
 877   sn_obj->header.info = &STABLE_NAME_info;
 878   sn_obj->sn = index;
 879
 880   TICK_RET_UNBOXED_TUP(1);
 881   RET_P(sn_obj);
 882 }
 883
 884 #endif /* COMPILER */
 885