ghc/rts/PrimOps.hc

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