ghc/rts/PrimOps.hc

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