ghc/rts/PrimOps.hc

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