ghc/rts/PrimOps.hc

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