ghc/rts/PrimOps.hc

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