ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.13 1999/02/05 16:02:45 simonm Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Primitive functions / data
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11
  12 #ifdef COMPILER
  13
  14 #include "RtsFlags.h"
  15 #include "StgStartup.h"
  16 #include "SchedAPI.h"
  17 #include "Schedule.h"
  18 #include "RtsUtils.h"
  19 #include "Storage.h"
  20 #include "BlockAlloc.h" /* tmp */
  21 #include "StablePriv.h"
  22
  23 /* ** temporary **
  24
  25    classes CCallable and CReturnable don't really exist, but the
  26    compiler insists on generating dictionaries containing references
  27    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
  28    for these.
  29 */
  30
  31 W_ GHC_ZCCCallable_static_info[0];
  32 W_ GHC_ZCCReturnable_static_info[0];
  33
  34 #ifndef aix_TARGET_OS /* AIX gives link errors with this as a const (RO assembler section) */
  35 const
  36 #endif
  37       StgClosure *PrelBase_Bool_closure_tbl[] = {
  38     &False_closure,
  39     &True_closure
  40 };
  41
  42 /* -----------------------------------------------------------------------------
  43    Macros for Hand-written primitives.
  44    -------------------------------------------------------------------------- */
  45
  46 /*
  47  * Horrible macros for returning unboxed tuples.
  48  *
  49  * How an unboxed tuple is returned depends on two factors:
  50  *    - the number of real registers we have available
  51  *    - the boxedness of the returned fields.
  52  *
  53  * To return an unboxed tuple from a primitive operation, we have macros
  54  * RET_<layout> where <layout> describes the boxedness of each field of the
  55  * unboxed tuple:  N indicates a non-pointer field, and P indicates a pointer.
  56  *
  57  * We only define the cases actually used, to avoid having too much
  58  * garbage in this section.  Warning: any bugs in here will be hard to
  59  * track down.
  60  */
  61
  62 /*------ All Regs available */
  63 #ifdef REG_R8
  64 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  65 # define RET_N(a)     RET_P(a)
  66
  67 # define RET_PP(a,b)  R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
  68 # define RET_NN(a,b)  RET_PP(a,b)
  69 # define RET_NP(a,b)  RET_PP(a,b)
  70
  71 # define RET_PPP(a,b,c) \
  72         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
  73 # define RET_NNP(a,b,c) RET_PPP(a,b,c)
  74
  75 # define RET_NNNP(a,b,c,d) \
  76         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
  77         JMP_(ENTRY_CODE(Sp[0]));
  78
  79 # define RET_NNPNNP(a,b,c,d,e,f) \
  80         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
  81         R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
  82         JMP_(ENTRY_CODE(Sp[0]));
  83
  84 #else
  85
  86 #if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
  87     defined(REG_R4) || defined(REG_R3) || defined(REG_R2)
  88 # error RET_n macros not defined for this setup.
  89 #else
  90
  91 /*------ 1 Register available */
  92 #ifdef REG_R1
  93 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  94 # define RET_N(a)     RET_P(a)
  95
  96 # define RET_PP(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
  97                        JMP_(ENTRY_CODE(Sp[1]));
  98 # define RET_NN(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
  99                        JMP_(ENTRY_CODE(Sp[2]));
 100 # define RET_NP(a,b)   RET_PP(a,b)
 101
 102 # define RET_PPP(a,b,c) \
 103         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
 104         JMP_(ENTRY_CODE(Sp[2]));
 105 # define RET_NNP(a,b,c) \
 106         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
 107         JMP_(ENTRY_CODE(Sp[3]));
 108
 109 # define RET_NNNP(a,b,c,d)                      \
 110         R1.w = (W_)(a);                         \
 111     /*  Sp[-5] = ARGTAG(1); */                  \
 112         Sp[-4] = (W_)(b);                       \
 113     /*  Sp[-3] = ARGTAG(1); */                  \
 114         Sp[-2] = (W_)(c);                       \
 115         Sp[-1] = (W_)(d);                       \
 116         Sp -= 5;                                \
 117         JMP_(ENTRY_CODE(Sp[5]));
 118
 119 # define RET_NNPNNP(a,b,c,d,e,f)                \
 120         R1.w = (W_)(a);                         \
 121         Sp[-1] = (W_)(f);                       \
 122         Sp[-2] = (W_)(e);                       \
 123         /* Sp[-3] = ARGTAG(1); */               \
 124         Sp[-4] = (W_)(d);                       \
 125         /* Sp[-5] = ARGTAG(1); */               \
 126         Sp[-6] = (W_)(c);                       \
 127         Sp[-7] = (W_)(b);                       \
 128         /* Sp[-8] = ARGTAG(1); */               \
 129         Sp -= 8;                                \
 130         JMP_(ENTRY_CODE(Sp[8]));
 131
 132 #else /* 0 Regs available */
 133
 134 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
 135 #define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
 136 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 137
 138 /* Here's how to construct these macros:
 139  *
 140  *   N = number of N's in the name;
 141  *   P = number of P's in the name;
 142  *   s = N * 2 + P;
 143  *   while (nonNull(name)) {
 144  *     if (nextChar == 'P') {
 145  *       PUSH_P(s,_);
 146  *       s -= 1;
 147  *     } else {
 148  *       PUSH_N(s,_);
 149  *       s -= 2
 150  *     }
 151  *   }
 152  *   PUSHED(N * 2 + P);
 153  */
 154
 155 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 156 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 157
 158 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 159 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 160 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 161
 162 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 163 # define RET_NNP(a,b,c) PUSH_N(6,a); PUSH_N(4,b); PUSH_N(2,c); PUSHED(6)
 164
 165 # 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)
 166 # 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)
 167
 168 #endif
 169
 170 #endif
 171 #endif
 172
 173 /*-----------------------------------------------------------------------------
 174   Array Primitives
 175
 176   Basically just new*Array - the others are all inline macros.
 177
 178   The size arg is always passed in R1, and the result returned in R1.
 179
 180   The slow entry point is for returning from a heap check, the saved
 181   size argument must be re-loaded from the stack.
 182   -------------------------------------------------------------------------- */
 183
 184 /* for objects that are *less* than the size of a word, make sure we
 185  * round up to the nearest word for the size of the array.
 186  */
 187
 188 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 189
 190 #define newByteArray(ty,scale)                          \
 191  FN_(new##ty##Arrayzh_fast)                             \
 192  {                                                      \
 193    W_ stuff_size, size, n;                              \
 194    StgArrWords* p;                                      \
 195    FB_                                                  \
 196      MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast);           \
 197      n = R1.w;                                          \
 198      stuff_size = BYTES_TO_STGWORDS(n*scale);           \
 199      size = sizeofW(StgArrWords)+ stuff_size;           \
 200      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 201      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 202      SET_HDR(p, &ARR_WORDS_info, CCCS);         \
 203      p->words = stuff_size;                             \
 204      TICK_RET_UNBOXED_TUP(1)                            \
 205      RET_P(p);                                          \
 206    FE_                                                  \
 207  }
 208
 209 newByteArray(Char,   sizeof(C_))
 210 newByteArray(Int,    sizeof(I_));
 211 newByteArray(Word,   sizeof(W_));
 212 newByteArray(Addr,   sizeof(P_));
 213 newByteArray(Float,  sizeof(StgFloat));
 214 newByteArray(Double, sizeof(StgDouble));
 215 newByteArray(StablePtr, sizeof(StgStablePtr));
 216
 217 FN_(newArrayzh_fast)
 218 {
 219   W_ size, n, init;
 220   StgMutArrPtrs* arr;
 221   StgPtr p;
 222   FB_
 223     n = R1.w;
 224
 225     MAYBE_GC(R2_PTR,newArrayzh_fast);
 226
 227     size = sizeofW(StgMutArrPtrs) + n;
 228     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 229     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 230
 231     SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
 232     arr->ptrs = n;
 233
 234     init = R2.w;
 235     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 236          p < (P_)arr + size; p++) {
 237         *p = (W_)init;
 238     }
 239
 240     TICK_RET_UNBOXED_TUP(1);
 241     RET_P(arr);
 242   FE_
 243 }
 244
 245 FN_(newMutVarzh_fast)
 246 {
 247   StgMutVar* mv;
 248   /* Args: R1.p = initialisation value */
 249   FB_
 250
 251   HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 252   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 253   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 254
 255   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 256   SET_HDR(mv,&MUT_VAR_info,CCCS);
 257   mv->var = R1.cl;
 258
 259   TICK_RET_UNBOXED_TUP(1);
 260   RET_P(mv);
 261   FE_
 262 }
 263
 264 /* -----------------------------------------------------------------------------
 265    Foreign Object Primitives
 266
 267    -------------------------------------------------------------------------- */
 268
 269 #ifndef PAR
 270 FN_(makeForeignObjzh_fast)
 271 {
 272   /* R1.p = ptr to foreign object,
 273   */
 274   StgForeignObj *result;
 275   FB_
 276
 277   HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
 278   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 279                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 280   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 281
 282   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 283   SET_HDR(result,&FOREIGN_info,CCCS);
 284   result->data = R1.p;
 285
 286   /* returns (# s#, ForeignObj# #) */
 287   TICK_RET_UNBOXED_TUP(1);
 288   RET_P(result);
 289   FE_
 290 }
 291 #endif
 292
 293 /* -----------------------------------------------------------------------------
 294    Weak Pointer Primitives
 295    -------------------------------------------------------------------------- */
 296
 297 #ifndef PAR
 298
 299 FN_(mkWeakzh_fast)
 300 {
 301   /* R1.p = key
 302      R2.p = value
 303      R3.p = finaliser
 304   */
 305   StgWeak *w;
 306   FB_
 307
 308   HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 309   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 310                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 311   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 312
 313   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 314   SET_HDR(w, &WEAK_info, CCCS);
 315
 316   w->key        = R1.cl;
 317   w->value      = R2.cl;
 318   if (R3.cl) {
 319      w->finaliser  = R3.cl;
 320   } else {
 321      w->finaliser  = &NO_FINALISER_closure;
 322   }
 323
 324   w->link       = weak_ptr_list;
 325   weak_ptr_list = w;
 326   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 327
 328   TICK_RET_UNBOXED_TUP(1);
 329   RET_P(w);
 330   FE_
 331 }
 332
 333 FN_(finaliseWeakzh_fast)
 334 {
 335   /* R1.p = weak ptr
 336    */
 337   StgWeak *w;
 338   FB_
 339   TICK_RET_UNBOXED_TUP(0);
 340   w = (StgWeak *)R1.p;
 341
 342   if (w->finaliser != &NO_FINALISER_closure) {
 343 #ifdef INTERPRETER
 344       STGCALL2(createGenThread, RtsFlags.GcFlags.initialStkSize, w->finaliser);
 345 #else
 346       STGCALL2(createIOThread, 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