ghc/rts/PrimOps.hc

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