ghc/rts/PrimOps.hc

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