ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.84 2001/11/08 12:46:31 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * Primitive functions / data
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Stg.h"
  11 #include "Rts.h"
  12
  13 #include "RtsFlags.h"
  14 #include "StgStartup.h"
  15 #include "SchedAPI.h"
  16 #include "Schedule.h"
  17 #include "RtsUtils.h"
  18 #include "Storage.h"
  19 #include "BlockAlloc.h" /* tmp */
  20 #include "StablePriv.h"
  21 #include "StgRun.h"
  22 #include "Itimer.h"
  23 #include "Prelude.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.  Some C compilers can't cope with zero-length static arrays,
  31    so we have to make these one element long.
  32 */
  33
  34 StgWord GHC_ZCCCallable_static_info[1];
  35 StgWord GHC_ZCCReturnable_static_info[1];
  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
 189 #ifdef DEBUG
 190 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);  Sp[-o] = ARG_TAG(1);
 191 #else
 192 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);
 193 #endif
 194
 195 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 196
 197 /* Here's how to construct these macros:
 198  *
 199  *   N = number of N's in the name;
 200  *   P = number of P's in the name;
 201  *   s = N * 2 + P;
 202  *   while (nonNull(name)) {
 203  *     if (nextChar == 'P') {
 204  *       PUSH_P(s,_);
 205  *       s -= 1;
 206  *     } else {
 207  *       PUSH_N(s,_);
 208  *       s -= 2
 209  *     }
 210  *   }
 211  *   PUSHED(N * 2 + P);
 212  */
 213
 214 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 215 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 216
 217 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 218 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 219 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 220
 221 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 222 # define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
 223
 224 # 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)
 225 # 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)
 226 # 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)
 227
 228 #endif
 229
 230 /*-----------------------------------------------------------------------------
 231   Array Primitives
 232
 233   Basically just new*Array - the others are all inline macros.
 234
 235   The size arg is always passed in R1, and the result returned in R1.
 236
 237   The slow entry point is for returning from a heap check, the saved
 238   size argument must be re-loaded from the stack.
 239   -------------------------------------------------------------------------- */
 240
 241 /* for objects that are *less* than the size of a word, make sure we
 242  * round up to the nearest word for the size of the array.
 243  */
 244
 245 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 246
 247 FN_(newByteArrayzh_fast)                                \
 248  {                                                      \
 249    W_ size, stuff_size, n;                              \
 250    StgArrWords* p;                                      \
 251    FB_                                                  \
 252      MAYBE_GC(NO_PTRS,newByteArrayzh_fast);             \
 253      n = R1.w;                                          \
 254      stuff_size = BYTES_TO_STGWORDS(n);                 \
 255      size = sizeofW(StgArrWords)+ stuff_size;           \
 256      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 257      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 258      SET_HDR(p, &stg_ARR_WORDS_info, CCCS);             \
 259      p->words = stuff_size;                             \
 260      TICK_RET_UNBOXED_TUP(1)                            \
 261      RET_P(p);                                          \
 262    FE_                                                  \
 263  }
 264
 265 FN_(newPinnedByteArrayzh_fast)                                  \
 266  {                                                              \
 267    W_ size, stuff_size, n;                                      \
 268    StgArrWords* p;                                              \
 269    FB_                                                          \
 270      MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);               \
 271      n = R1.w;                                                  \
 272      stuff_size = BYTES_TO_STGWORDS(n);                         \
 273      size = sizeofW(StgArrWords)+ stuff_size;                   \
 274      p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size);   \
 275      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0);        \
 276      SET_HDR(p, &stg_ARR_WORDS_info, CCCS);                     \
 277      p->words = stuff_size;                                     \
 278      TICK_RET_UNBOXED_TUP(1)                                    \
 279      RET_P(p);                                                  \
 280    FE_                                                          \
 281  }
 282
 283 FN_(newArrayzh_fast)
 284 {
 285   W_ size, n, init;
 286   StgMutArrPtrs* arr;
 287   StgPtr p;
 288   FB_
 289     n = R1.w;
 290
 291     MAYBE_GC(R2_PTR,newArrayzh_fast);
 292
 293     size = sizeofW(StgMutArrPtrs) + n;
 294     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 295     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 296
 297     SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
 298     arr->ptrs = n;
 299
 300     init = R2.w;
 301     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 302          p < (P_)arr + size; p++) {
 303         *p = (W_)init;
 304     }
 305
 306     TICK_RET_UNBOXED_TUP(1);
 307     RET_P(arr);
 308   FE_
 309 }
 310
 311 FN_(newMutVarzh_fast)
 312 {
 313   StgMutVar* mv;
 314   /* Args: R1.p = initialisation value */
 315   FB_
 316
 317   HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 318   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 319   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 320
 321   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 322   SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
 323   mv->var = R1.cl;
 324
 325   TICK_RET_UNBOXED_TUP(1);
 326   RET_P(mv);
 327   FE_
 328 }
 329
 330 /* -----------------------------------------------------------------------------
 331    Foreign Object Primitives
 332
 333    -------------------------------------------------------------------------- */
 334
 335 FN_(mkForeignObjzh_fast)
 336 {
 337   /* R1.p = ptr to foreign object,
 338   */
 339   StgForeignObj *result;
 340   FB_
 341
 342   HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast,);
 343   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 344                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 345   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 346
 347   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 348   SET_HDR(result,&stg_FOREIGN_info,CCCS);
 349   result->data = R1.p;
 350
 351   /* returns (# s#, ForeignObj# #) */
 352   TICK_RET_UNBOXED_TUP(1);
 353   RET_P(result);
 354   FE_
 355 }
 356
 357 /* These two are out-of-line for the benefit of the NCG */
 358 FN_(unsafeThawArrayzh_fast)
 359 {
 360   FB_
 361   SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
 362   recordMutable((StgMutClosure*)R1.cl);
 363
 364   TICK_RET_UNBOXED_TUP(1);
 365   RET_P(R1.p);
 366   FE_
 367 }
 368
 369 /* -----------------------------------------------------------------------------
 370    Weak Pointer Primitives
 371    -------------------------------------------------------------------------- */
 372
 373 FN_(mkWeakzh_fast)
 374 {
 375   /* R1.p = key
 376      R2.p = value
 377      R3.p = finalizer (or NULL)
 378   */
 379   StgWeak *w;
 380   FB_
 381
 382   if (R3.cl == NULL) {
 383     R3.cl = &stg_NO_FINALIZER_closure;
 384   }
 385
 386   HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 387   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 388                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 389   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 390
 391   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 392   SET_HDR(w, &stg_WEAK_info, CCCS);
 393
 394   w->key        = R1.cl;
 395   w->value      = R2.cl;
 396   w->finalizer  = R3.cl;
 397
 398   w->link       = weak_ptr_list;
 399   weak_ptr_list = w;
 400   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 401
 402   TICK_RET_UNBOXED_TUP(1);
 403   RET_P(w);
 404   FE_
 405 }
 406
 407 FN_(finalizzeWeakzh_fast)
 408 {
 409   /* R1.p = weak ptr
 410    */
 411   StgDeadWeak *w;
 412   StgClosure *f;
 413   FB_
 414   TICK_RET_UNBOXED_TUP(0);
 415   w = (StgDeadWeak *)R1.p;
 416
 417   /* already dead? */
 418   if (w->header.info == &stg_DEAD_WEAK_info) {
 419       RET_NP(0,&stg_NO_FINALIZER_closure);
 420   }
 421
 422   /* kill it */
 423   w->header.info = &stg_DEAD_WEAK_info;
 424   f = ((StgWeak *)w)->finalizer;
 425   w->link = ((StgWeak *)w)->link;
 426
 427   /* return the finalizer */
 428   if (f == &stg_NO_FINALIZER_closure) {
 429       RET_NP(0,&stg_NO_FINALIZER_closure);
 430   } else {
 431       RET_NP(1,f);
 432   }
 433   FE_
 434 }
 435
 436 /* -----------------------------------------------------------------------------
 437    Arbitrary-precision Integer operations.
 438    -------------------------------------------------------------------------- */
 439
 440 FN_(int2Integerzh_fast)
 441 {
 442    /* arguments: R1 = Int# */
 443
 444    I_ val, s;           /* to avoid aliasing */
 445    StgArrWords* p;      /* address of array result */
 446    FB_
 447
 448    val = R1.i;
 449    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 450    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 451    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 452
 453    p = (StgArrWords *)Hp - 1;
 454    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 455
 456    /* mpz_set_si is inlined here, makes things simpler */
 457    if (val < 0) {
 458         s  = -1;
 459         *Hp = -val;
 460    } else if (val > 0) {
 461         s = 1;
 462         *Hp = val;
 463    } else {
 464         s = 0;
 465    }
 466
 467    /* returns (# size  :: Int#,
 468                  data  :: ByteArray#
 469                #)
 470    */
 471    TICK_RET_UNBOXED_TUP(2);
 472    RET_NP(s,p);
 473    FE_
 474 }
 475
 476 FN_(word2Integerzh_fast)
 477 {
 478    /* arguments: R1 = Word# */
 479
 480    W_ val;              /* to avoid aliasing */
 481    I_  s;
 482    StgArrWords* p;      /* address of array result */
 483    FB_
 484
 485    val = R1.w;
 486    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 487    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 488    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 489
 490    p = (StgArrWords *)Hp - 1;
 491    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 492
 493    if (val != 0) {
 494         s = 1;
 495         *Hp = val;
 496    } else {
 497         s = 0;
 498    }
 499
 500    /* returns (# size  :: Int#,
 501                  data  :: ByteArray#
 502                #)
 503    */
 504    TICK_RET_UNBOXED_TUP(2);
 505    RET_NP(s,p);
 506    FE_
 507 }
 508
 509
 510 /*
 511  * 'long long' primops for converting to/from Integers.
 512  */
 513
 514 #ifdef SUPPORT_LONG_LONGS
 515
 516 FN_(int64ToIntegerzh_fast)
 517 {
 518    /* arguments: L1 = Int64# */
 519
 520    StgInt64  val; /* to avoid aliasing */
 521    W_ hi;
 522    I_  s, neg, words_needed;
 523    StgArrWords* p;      /* address of array result */
 524    FB_
 525
 526    val = (LI_)L1;
 527    neg = 0;
 528
 529    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 530        words_needed = 2;
 531    } else {
 532        /* minimum is one word */
 533        words_needed = 1;
 534    }
 535    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 536    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 537    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 538
 539    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 540    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 541
 542    if ( val < 0LL ) {
 543      neg = 1;
 544      val = -val;
 545    }
 546
 547    hi = (W_)((LW_)val / 0x100000000ULL);
 548
 549    if ( words_needed == 2 )  {
 550       s = 2;
 551       Hp[-1] = (W_)val;
 552       Hp[0] = hi;
 553    } else if ( val != 0 ) {
 554       s = 1;
 555       Hp[0] = (W_)val;
 556    }  else /* val==0 */   {
 557       s = 0;
 558    }
 559    s = ( neg ? -s : s );
 560
 561    /* returns (# size  :: Int#,
 562                  data  :: ByteArray#
 563                #)
 564    */
 565    TICK_RET_UNBOXED_TUP(2);
 566    RET_NP(s,p);
 567    FE_
 568 }
 569
 570 FN_(word64ToIntegerzh_fast)
 571 {
 572    /* arguments: L1 = Word64# */
 573
 574    StgWord64 val; /* to avoid aliasing */
 575    StgWord hi;
 576    I_  s, words_needed;
 577    StgArrWords* p;      /* address of array result */
 578    FB_
 579
 580    val = (LW_)L1;
 581    if ( val >= 0x100000000ULL ) {
 582       words_needed = 2;
 583    } else {
 584       words_needed = 1;
 585    }
 586    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 587    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 588    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 589
 590    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 591    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 592
 593    hi = (W_)((LW_)val / 0x100000000ULL);
 594    if ( val >= 0x100000000ULL ) {
 595      s = 2;
 596      Hp[-1] = ((W_)val);
 597      Hp[0]  = (hi);
 598    } else if ( val != 0 )      {
 599       s = 1;
 600       Hp[0] = ((W_)val);
 601    } else /* val==0 */         {
 602       s = 0;
 603    }
 604
 605    /* returns (# size  :: Int#,
 606                  data  :: ByteArray#
 607                #)
 608    */
 609    TICK_RET_UNBOXED_TUP(2);
 610    RET_NP(s,p);
 611    FE_
 612 }
 613
 614
 615 #endif /* SUPPORT_LONG_LONGS */
 616
 617 /* ToDo: this is shockingly inefficient */
 618
 619 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 620 FN_(name)                                                               \
 621 {                                                                       \
 622   MP_INT arg1, arg2, result;                                            \
 623   I_ s1, s2;                                                            \
 624   StgArrWords* d1;                                                      \
 625   StgArrWords* d2;                                                      \
 626   FB_                                                                   \
 627                                                                         \
 628   /* call doYouWantToGC() */                                            \
 629   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 630                                                                         \
 631   d1 = (StgArrWords *)R2.p;                                             \
 632   s1 = R1.i;                                                            \
 633   d2 = (StgArrWords *)R4.p;                                             \
 634   s2 = R3.i;                                                            \
 635                                                                         \
 636   arg1._mp_alloc        = d1->words;                                    \
 637   arg1._mp_size         = (s1);                                         \
 638   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 639   arg2._mp_alloc        = d2->words;                                    \
 640   arg2._mp_size         = (s2);                                         \
 641   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 642                                                                         \
 643   STGCALL1(mpz_init,&result);                                           \
 644                                                                         \
 645   /* Perform the operation */                                           \
 646   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 647                                                                         \
 648   TICK_RET_UNBOXED_TUP(2);                                              \
 649   RET_NP(result._mp_size,                                               \
 650          result._mp_d-sizeofW(StgArrWords));                            \
 651   FE_                                                                   \
 652 }
 653
 654 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
 655 FN_(name)                                                               \
 656 {                                                                       \
 657   MP_INT arg1, result;                                                  \
 658   I_ s1;                                                                \
 659   StgArrWords* d1;                                                      \
 660   FB_                                                                   \
 661                                                                         \
 662   /* call doYouWantToGC() */                                            \
 663   MAYBE_GC(R2_PTR, name);                                               \
 664                                                                         \
 665   d1 = (StgArrWords *)R2.p;                                             \
 666   s1 = R1.i;                                                            \
 667                                                                         \
 668   arg1._mp_alloc        = d1->words;                                    \
 669   arg1._mp_size         = (s1);                                         \
 670   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 671                                                                         \
 672   STGCALL1(mpz_init,&result);                                           \
 673                                                                         \
 674   /* Perform the operation */                                           \
 675   STGCALL2(mp_fun,&result,&arg1);                                       \
 676                                                                         \
 677   TICK_RET_UNBOXED_TUP(2);                                              \
 678   RET_NP(result._mp_size,                                               \
 679          result._mp_d-sizeofW(StgArrWords));                            \
 680   FE_                                                                   \
 681 }
 682
 683 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 684 FN_(name)                                                               \
 685 {                                                                       \
 686   MP_INT arg1, arg2, result1, result2;                                  \
 687   I_ s1, s2;                                                            \
 688   StgArrWords* d1;                                                      \
 689   StgArrWords* d2;                                                      \
 690   FB_                                                                   \
 691                                                                         \
 692   /* call doYouWantToGC() */                                            \
 693   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 694                                                                         \
 695   d1 = (StgArrWords *)R2.p;                                             \
 696   s1 = R1.i;                                                            \
 697   d2 = (StgArrWords *)R4.p;                                             \
 698   s2 = R3.i;                                                            \
 699                                                                         \
 700   arg1._mp_alloc        = d1->words;                                    \
 701   arg1._mp_size         = (s1);                                         \
 702   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 703   arg2._mp_alloc        = d2->words;                                    \
 704   arg2._mp_size         = (s2);                                         \
 705   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 706                                                                         \
 707   STGCALL1(mpz_init,&result1);                                          \
 708   STGCALL1(mpz_init,&result2);                                          \
 709                                                                         \
 710   /* Perform the operation */                                           \
 711   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 712                                                                         \
 713   TICK_RET_UNBOXED_TUP(4);                                              \
 714   RET_NPNP(result1._mp_size,                                            \
 715            result1._mp_d-sizeofW(StgArrWords),                          \
 716            result2._mp_size,                                            \
 717            result2._mp_d-sizeofW(StgArrWords));                         \
 718   FE_                                                                   \
 719 }
 720
 721 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 722 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 723 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 724 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 725 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 726 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 727 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 728 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and);
 729 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior);
 730 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor);
 731 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
 732
 733 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 734 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 735
 736 FN_(decodeFloatzh_fast)
 737 {
 738   MP_INT mantissa;
 739   I_ exponent;
 740   StgArrWords* p;
 741   StgFloat arg;
 742   FB_
 743
 744   /* arguments: F1 = Float# */
 745   arg = F1;
 746
 747   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 748   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 749   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 750
 751   /* Be prepared to tell Lennart-coded __decodeFloat    */
 752   /* where mantissa._mp_d can be put (it does not care about the rest) */
 753   p = (StgArrWords *)Hp - 1;
 754   SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
 755   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 756
 757   /* Perform the operation */
 758   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 759
 760   /* returns: (Int# (expn), Int#, ByteArray#) */
 761   TICK_RET_UNBOXED_TUP(3);
 762   RET_NNP(exponent,mantissa._mp_size,p);
 763   FE_
 764 }
 765
 766 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 767 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 768
 769 FN_(decodeDoublezh_fast)
 770 { MP_INT mantissa;
 771   I_ exponent;
 772   StgDouble arg;
 773   StgArrWords* p;
 774   FB_
 775
 776   /* arguments: D1 = Double# */
 777   arg = D1;
 778
 779   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 780   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 781   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 782
 783   /* Be prepared to tell Lennart-coded __decodeDouble   */
 784   /* where mantissa.d can be put (it does not care about the rest) */
 785   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 786   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 787   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 788
 789   /* Perform the operation */
 790   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 791
 792   /* returns: (Int# (expn), Int#, ByteArray#) */
 793   TICK_RET_UNBOXED_TUP(3);
 794   RET_NNP(exponent,mantissa._mp_size,p);
 795   FE_
 796 }
 797
 798 /* -----------------------------------------------------------------------------
 799  * Concurrency primitives
 800  * -------------------------------------------------------------------------- */
 801
 802 FN_(forkzh_fast)
 803 {
 804   FB_
 805   /* args: R1 = closure to spark */
 806
 807   MAYBE_GC(R1_PTR, forkzh_fast);
 808
 809   /* create it right now, return ThreadID in R1 */
 810   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 811                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 812   STGCALL1(scheduleThread, R1.t);
 813
 814   /* switch at the earliest opportunity */
 815   context_switch = 1;
 816
 817   JMP_(ENTRY_CODE(Sp[0]));
 818   FE_
 819 }
 820
 821 FN_(yieldzh_fast)
 822 {
 823   FB_
 824   JMP_(stg_yield_noregs);
 825   FE_
 826 }
 827
 828 /* -----------------------------------------------------------------------------
 829  * MVar primitives
 830  *
 831  * take & putMVar work as follows.  Firstly, an important invariant:
 832  *
 833  *    If the MVar is full, then the blocking queue contains only
 834  *    threads blocked on putMVar, and if the MVar is empty then the
 835  *    blocking queue contains only threads blocked on takeMVar.
 836  *
 837  * takeMvar:
 838  *    MVar empty : then add ourselves to the blocking queue
 839  *    MVar full  : remove the value from the MVar, and
 840  *                 blocking queue empty     : return
 841  *                 blocking queue non-empty : perform the first blocked putMVar
 842  *                                            from the queue, and wake up the
 843  *                                            thread (MVar is now full again)
 844  *
 845  * putMVar is just the dual of the above algorithm.
 846  *
 847  * How do we "perform a putMVar"?  Well, we have to fiddle around with
 848  * the stack of the thread waiting to do the putMVar.  See
 849  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
 850  * the stack layout, and the PerformPut and PerformTake macros below.
 851  *
 852  * It is important that a blocked take or put is woken up with the
 853  * take/put already performed, because otherwise there would be a
 854  * small window of vulnerability where the thread could receive an
 855  * exception and never perform its take or put, and we'd end up with a
 856  * deadlock.
 857  *
 858  * -------------------------------------------------------------------------- */
 859
 860 FN_(newMVarzh_fast)
 861 {
 862   StgMVar *mvar;
 863
 864   FB_
 865   /* args: none */
 866
 867   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 868   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 869                   1, 0);
 870   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 871
 872   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 873   SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
 874   mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 875   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 876
 877   TICK_RET_UNBOXED_TUP(1);
 878   RET_P(mvar);
 879   FE_
 880 }
 881
 882 #define PerformTake(tso, value) ({                      \
 883     (tso)->sp[1] = (W_)value;                           \
 884     (tso)->sp[0] = (W_)&stg_gc_unpt_r1_ret_info;        \
 885   })
 886
 887 #define PerformPut(tso) ({                              \
 888     StgClosure *val = (StgClosure *)(tso)->sp[2];       \
 889     (tso)->sp[2] = (W_)&stg_gc_noregs_ret_info;         \
 890     (tso)->sp += 2;                                     \
 891     val;                                                \
 892   })
 893
 894 FN_(takeMVarzh_fast)
 895 {
 896   StgMVar *mvar;
 897   StgClosure *val;
 898   const StgInfoTable *info;
 899
 900   FB_
 901   /* args: R1 = MVar closure */
 902
 903   mvar = (StgMVar *)R1.p;
 904
 905 #ifdef SMP
 906   info = LOCK_CLOSURE(mvar);
 907 #else
 908   info = GET_INFO(mvar);
 909 #endif
 910
 911   /* If the MVar is empty, put ourselves on its blocking queue,
 912    * and wait until we're woken up.
 913    */
 914   if (info == &stg_EMPTY_MVAR_info) {
 915     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 916       mvar->head = CurrentTSO;
 917     } else {
 918       mvar->tail->link = CurrentTSO;
 919     }
 920     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 921     CurrentTSO->why_blocked = BlockedOnMVar;
 922     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 923     mvar->tail = CurrentTSO;
 924
 925 #ifdef SMP
 926     /* unlock the MVar */
 927     mvar->header.info = &stg_EMPTY_MVAR_info;
 928 #endif
 929     JMP_(stg_block_takemvar);
 930   }
 931
 932   /* we got the value... */
 933   val = mvar->value;
 934
 935   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 936       /* There are putMVar(s) waiting...
 937        * wake up the first thread on the queue
 938        */
 939       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 940
 941       /* actually perform the putMVar for the thread that we just woke up */
 942       mvar->value = PerformPut(mvar->head);
 943
 944 #if defined(GRAN) || defined(PAR)
 945       /* ToDo: check 2nd arg (mvar) is right */
 946       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 947 #else
 948       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 949 #endif
 950       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 951           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 952       }
 953 #ifdef SMP
 954       /* unlock in the SMP case */
 955       SET_INFO(mvar,&stg_FULL_MVAR_info);
 956 #endif
 957       TICK_RET_UNBOXED_TUP(1);
 958       RET_P(val);
 959   } else {
 960       /* No further putMVars, MVar is now empty */
 961
 962       /* do this last... we might have locked the MVar in the SMP case,
 963        * and writing the info pointer will unlock it.
 964        */
 965       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 966       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 967       TICK_RET_UNBOXED_TUP(1);
 968       RET_P(val);
 969   }
 970   FE_
 971 }
 972
 973 FN_(tryTakeMVarzh_fast)
 974 {
 975   StgMVar *mvar;
 976   StgClosure *val;
 977   const StgInfoTable *info;
 978
 979   FB_
 980   /* args: R1 = MVar closure */
 981
 982   mvar = (StgMVar *)R1.p;
 983
 984 #ifdef SMP
 985   info = LOCK_CLOSURE(mvar);
 986 #else
 987   info = GET_INFO(mvar);
 988 #endif
 989
 990   if (info == &stg_EMPTY_MVAR_info) {
 991
 992 #ifdef SMP
 993       /* unlock the MVar */
 994       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 995 #endif
 996
 997       /* HACK: we need a pointer to pass back,
 998        * so we abuse NO_FINALIZER_closure
 999        */
1000       RET_NP(0, &stg_NO_FINALIZER_closure);
1001   }
1002
1003   /* we got the value... */
1004   val = mvar->value;
1005
1006   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1007       /* There are putMVar(s) waiting...
1008        * wake up the first thread on the queue
1009        */
1010       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1011
1012       /* actually perform the putMVar for the thread that we just woke up */
1013       mvar->value = PerformPut(mvar->head);
1014
1015 #if defined(GRAN) || defined(PAR)
1016       /* ToDo: check 2nd arg (mvar) is right */
1017       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1018 #else
1019       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1020 #endif
1021       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1022           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1023       }
1024 #ifdef SMP
1025       /* unlock in the SMP case */
1026       SET_INFO(mvar,&stg_FULL_MVAR_info);
1027 #endif
1028       TICK_RET_UNBOXED_TUP(1);
1029       RET_P(val);
1030   } else {
1031       /* No further putMVars, MVar is now empty */
1032
1033       /* do this last... we might have locked the MVar in the SMP case,
1034        * and writing the info pointer will unlock it.
1035        */
1036       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1037       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1038       TICK_RET_UNBOXED_TUP(1);
1039       RET_P(val);
1040   }
1041   FE_
1042 }
1043
1044 FN_(putMVarzh_fast)
1045 {
1046   StgMVar *mvar;
1047   const StgInfoTable *info;
1048
1049   FB_
1050   /* args: R1 = MVar, R2 = value */
1051
1052   mvar = (StgMVar *)R1.p;
1053
1054 #ifdef SMP
1055   info = LOCK_CLOSURE(mvar);
1056 #else
1057   info = GET_INFO(mvar);
1058 #endif
1059
1060   if (info == &stg_FULL_MVAR_info) {
1061     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1062       mvar->head = CurrentTSO;
1063     } else {
1064       mvar->tail->link = CurrentTSO;
1065     }
1066     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1067     CurrentTSO->why_blocked = BlockedOnMVar;
1068     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1069     mvar->tail = CurrentTSO;
1070
1071 #ifdef SMP
1072     /* unlock the MVar */
1073     SET_INFO(mvar,&stg_FULL_MVAR_info);
1074 #endif
1075     JMP_(stg_block_putmvar);
1076   }
1077
1078   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1079       /* There are takeMVar(s) waiting: wake up the first one
1080        */
1081       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1082
1083       /* actually perform the takeMVar */
1084       PerformTake(mvar->head, R2.cl);
1085
1086 #if defined(GRAN) || defined(PAR)
1087       /* ToDo: check 2nd arg (mvar) is right */
1088       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1089 #else
1090       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1091 #endif
1092       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1093           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1094       }
1095 #ifdef SMP
1096       /* unlocks the MVar in the SMP case */
1097       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1098 #endif
1099       JMP_(ENTRY_CODE(Sp[0]));
1100   } else {
1101       /* No further takes, the MVar is now full. */
1102       mvar->value = R2.cl;
1103       /* unlocks the MVar in the SMP case */
1104       SET_INFO(mvar,&stg_FULL_MVAR_info);
1105       JMP_(ENTRY_CODE(Sp[0]));
1106   }
1107
1108   /* ToDo: yield afterward for better communication performance? */
1109   FE_
1110 }
1111
1112 FN_(tryPutMVarzh_fast)
1113 {
1114   StgMVar *mvar;
1115   const StgInfoTable *info;
1116
1117   FB_
1118   /* args: R1 = MVar, R2 = value */
1119
1120   mvar = (StgMVar *)R1.p;
1121
1122 #ifdef SMP
1123   info = LOCK_CLOSURE(mvar);
1124 #else
1125   info = GET_INFO(mvar);
1126 #endif
1127
1128   if (info == &stg_FULL_MVAR_info) {
1129
1130 #ifdef SMP
1131     /* unlock the MVar */
1132     mvar->header.info = &stg_FULL_MVAR_info;
1133 #endif
1134
1135     RET_N(0);
1136   }
1137
1138   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1139       /* There are takeMVar(s) waiting: wake up the first one
1140        */
1141       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1142
1143       /* actually perform the takeMVar */
1144       PerformTake(mvar->head, R2.cl);
1145
1146 #if defined(GRAN) || defined(PAR)
1147       /* ToDo: check 2nd arg (mvar) is right */
1148       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1149 #else
1150       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1151 #endif
1152       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1153           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1154       }
1155 #ifdef SMP
1156       /* unlocks the MVar in the SMP case */
1157       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1158 #endif
1159       JMP_(ENTRY_CODE(Sp[0]));
1160   } else {
1161       /* No further takes, the MVar is now full. */
1162       mvar->value = R2.cl;
1163       /* unlocks the MVar in the SMP case */
1164       SET_INFO(mvar,&stg_FULL_MVAR_info);
1165       JMP_(ENTRY_CODE(Sp[0]));
1166   }
1167
1168   /* ToDo: yield afterward for better communication performance? */
1169   FE_
1170 }
1171
1172 /* -----------------------------------------------------------------------------
1173    Stable pointer primitives
1174    -------------------------------------------------------------------------  */
1175
1176 FN_(makeStableNamezh_fast)
1177 {
1178   StgWord index;
1179   StgStableName *sn_obj;
1180   FB_
1181
1182   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1183   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1184                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1185   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1186
1187   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1188
1189   /* Is there already a StableName for this heap object? */
1190   if (stable_ptr_table[index].sn_obj == NULL) {
1191     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1192     SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
1193     sn_obj->sn = index;
1194     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1195   } else {
1196     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1197   }
1198
1199   TICK_RET_UNBOXED_TUP(1);
1200   RET_P(sn_obj);
1201 }
1202
1203 /* -----------------------------------------------------------------------------
1204    Bytecode object primitives
1205    -------------------------------------------------------------------------  */
1206
1207 FN_(newBCOzh_fast)
1208 {
1209   /* R1.p = instrs
1210      R2.p = literals
1211      R3.p = ptrs
1212      R4.p = itbls
1213   */
1214   StgBCO *bco;
1215   FB_
1216
1217   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
1218   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1219   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1220   bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
1221   SET_HDR(bco, &stg_BCO_info, CCCS);
1222
1223   bco->instrs     = (StgArrWords*)R1.cl;
1224   bco->literals   = (StgArrWords*)R2.cl;
1225   bco->ptrs       = (StgMutArrPtrs*)R3.cl;
1226   bco->itbls      = (StgArrWords*)R4.cl;
1227
1228   TICK_RET_UNBOXED_TUP(1);
1229   RET_P(bco);
1230   FE_
1231 }
1232
1233 FN_(mkApUpd0zh_fast)
1234 {
1235   /* R1.p = the fn for the AP_UPD
1236   */
1237   StgAP_UPD* ap;
1238   FB_
1239   HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
1240   TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
1241   CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
1242   ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
1243   SET_HDR(ap, &stg_AP_UPD_info, CCCS);
1244
1245   ap->n_args = 0;
1246   ap->fun = R1.cl;
1247
1248   TICK_RET_UNBOXED_TUP(1);
1249   RET_P(ap);
1250   FE_
1251 }
1252
1253 /* -----------------------------------------------------------------------------
1254    Thread I/O blocking primitives
1255    -------------------------------------------------------------------------- */
1256
1257 FN_(waitReadzh_fast)
1258 {
1259   FB_
1260     /* args: R1.i */
1261     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1262     CurrentTSO->why_blocked = BlockedOnRead;
1263     CurrentTSO->block_info.fd = R1.i;
1264     ACQUIRE_LOCK(&sched_mutex);
1265     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1266     RELEASE_LOCK(&sched_mutex);
1267     JMP_(stg_block_noregs);
1268   FE_
1269 }
1270
1271 FN_(waitWritezh_fast)
1272 {
1273   FB_
1274     /* args: R1.i */
1275     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1276     CurrentTSO->why_blocked = BlockedOnWrite;
1277     CurrentTSO->block_info.fd = R1.i;
1278     ACQUIRE_LOCK(&sched_mutex);
1279     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1280     RELEASE_LOCK(&sched_mutex);
1281     JMP_(stg_block_noregs);
1282   FE_
1283 }
1284
1285 FN_(delayzh_fast)
1286 {
1287   StgTSO *t, *prev;
1288   nat target;
1289   FB_
1290     /* args: R1.i */
1291     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1292     CurrentTSO->why_blocked = BlockedOnDelay;
1293
1294     ACQUIRE_LOCK(&sched_mutex);
1295
1296     target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
1297     CurrentTSO->block_info.target = target;
1298
1299     /* Insert the new thread in the sleeping queue. */
1300     prev = NULL;
1301     t = sleeping_queue;
1302     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1303         prev = t;
1304         t = t->link;
1305     }
1306
1307     CurrentTSO->link = t;
1308     if (prev == NULL) {
1309         sleeping_queue = CurrentTSO;
1310     } else {
1311         prev->link = CurrentTSO;
1312     }
1313
1314     RELEASE_LOCK(&sched_mutex);
1315     JMP_(stg_block_noregs);
1316   FE_
1317 }
1318