ghc/rts/PrimOps.hc

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