ghc/rts/PrimOps.hc

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