ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.85 2001/11/22 14:25:12 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 #ifdef PROFILING
 424   // @LDV profiling
 425   // A weak pointer is inherently used, so we do not need to call
 426   // LDV_recordDead_FILL_SLOP_DYNAMIC():
 427   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
 428   // or, LDV_recordDead():
 429   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
 430   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as
 431   // large as weak pointers, so there is no need to fill the slop, either.
 432   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
 433 #endif
 434   //
 435   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
 436   //
 437   w->header.info = &stg_DEAD_WEAK_info;
 438 #ifdef PROFILING
 439   // @LDV profiling
 440   LDV_recordCreate((StgClosure *)w);
 441 #endif
 442   f = ((StgWeak *)w)->finalizer;
 443   w->link = ((StgWeak *)w)->link;
 444
 445   /* return the finalizer */
 446   if (f == &stg_NO_FINALIZER_closure) {
 447       RET_NP(0,&stg_NO_FINALIZER_closure);
 448   } else {
 449       RET_NP(1,f);
 450   }
 451   FE_
 452 }
 453
 454 /* -----------------------------------------------------------------------------
 455    Arbitrary-precision Integer operations.
 456    -------------------------------------------------------------------------- */
 457
 458 FN_(int2Integerzh_fast)
 459 {
 460    /* arguments: R1 = Int# */
 461
 462    I_ val, s;           /* to avoid aliasing */
 463    StgArrWords* p;      /* address of array result */
 464    FB_
 465
 466    val = R1.i;
 467    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 468    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 469    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 470
 471    p = (StgArrWords *)Hp - 1;
 472    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 473
 474    /* mpz_set_si is inlined here, makes things simpler */
 475    if (val < 0) {
 476         s  = -1;
 477         *Hp = -val;
 478    } else if (val > 0) {
 479         s = 1;
 480         *Hp = val;
 481    } else {
 482         s = 0;
 483    }
 484
 485    /* returns (# size  :: Int#,
 486                  data  :: ByteArray#
 487                #)
 488    */
 489    TICK_RET_UNBOXED_TUP(2);
 490    RET_NP(s,p);
 491    FE_
 492 }
 493
 494 FN_(word2Integerzh_fast)
 495 {
 496    /* arguments: R1 = Word# */
 497
 498    W_ val;              /* to avoid aliasing */
 499    I_  s;
 500    StgArrWords* p;      /* address of array result */
 501    FB_
 502
 503    val = R1.w;
 504    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 505    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 506    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 507
 508    p = (StgArrWords *)Hp - 1;
 509    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
 510
 511    if (val != 0) {
 512         s = 1;
 513         *Hp = val;
 514    } else {
 515         s = 0;
 516    }
 517
 518    /* returns (# size  :: Int#,
 519                  data  :: ByteArray#
 520                #)
 521    */
 522    TICK_RET_UNBOXED_TUP(2);
 523    RET_NP(s,p);
 524    FE_
 525 }
 526
 527
 528 /*
 529  * 'long long' primops for converting to/from Integers.
 530  */
 531
 532 #ifdef SUPPORT_LONG_LONGS
 533
 534 FN_(int64ToIntegerzh_fast)
 535 {
 536    /* arguments: L1 = Int64# */
 537
 538    StgInt64  val; /* to avoid aliasing */
 539    W_ hi;
 540    I_  s, neg, words_needed;
 541    StgArrWords* p;      /* address of array result */
 542    FB_
 543
 544    val = (LI_)L1;
 545    neg = 0;
 546
 547    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 548        words_needed = 2;
 549    } else {
 550        /* minimum is one word */
 551        words_needed = 1;
 552    }
 553    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 554    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 555    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 556
 557    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 558    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 559
 560    if ( val < 0LL ) {
 561      neg = 1;
 562      val = -val;
 563    }
 564
 565    hi = (W_)((LW_)val / 0x100000000ULL);
 566
 567    if ( words_needed == 2 )  {
 568       s = 2;
 569       Hp[-1] = (W_)val;
 570       Hp[0] = hi;
 571    } else if ( val != 0 ) {
 572       s = 1;
 573       Hp[0] = (W_)val;
 574    }  else /* val==0 */   {
 575       s = 0;
 576    }
 577    s = ( neg ? -s : s );
 578
 579    /* returns (# size  :: Int#,
 580                  data  :: ByteArray#
 581                #)
 582    */
 583    TICK_RET_UNBOXED_TUP(2);
 584    RET_NP(s,p);
 585    FE_
 586 }
 587
 588 FN_(word64ToIntegerzh_fast)
 589 {
 590    /* arguments: L1 = Word64# */
 591
 592    StgWord64 val; /* to avoid aliasing */
 593    StgWord hi;
 594    I_  s, words_needed;
 595    StgArrWords* p;      /* address of array result */
 596    FB_
 597
 598    val = (LW_)L1;
 599    if ( val >= 0x100000000ULL ) {
 600       words_needed = 2;
 601    } else {
 602       words_needed = 1;
 603    }
 604    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 605    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 606    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 607
 608    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 609    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
 610
 611    hi = (W_)((LW_)val / 0x100000000ULL);
 612    if ( val >= 0x100000000ULL ) {
 613      s = 2;
 614      Hp[-1] = ((W_)val);
 615      Hp[0]  = (hi);
 616    } else if ( val != 0 )      {
 617       s = 1;
 618       Hp[0] = ((W_)val);
 619    } else /* val==0 */         {
 620       s = 0;
 621    }
 622
 623    /* returns (# size  :: Int#,
 624                  data  :: ByteArray#
 625                #)
 626    */
 627    TICK_RET_UNBOXED_TUP(2);
 628    RET_NP(s,p);
 629    FE_
 630 }
 631
 632
 633 #endif /* SUPPORT_LONG_LONGS */
 634
 635 /* ToDo: this is shockingly inefficient */
 636
 637 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 638 FN_(name)                                                               \
 639 {                                                                       \
 640   MP_INT arg1, arg2, result;                                            \
 641   I_ s1, s2;                                                            \
 642   StgArrWords* d1;                                                      \
 643   StgArrWords* d2;                                                      \
 644   FB_                                                                   \
 645                                                                         \
 646   /* call doYouWantToGC() */                                            \
 647   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 648                                                                         \
 649   d1 = (StgArrWords *)R2.p;                                             \
 650   s1 = R1.i;                                                            \
 651   d2 = (StgArrWords *)R4.p;                                             \
 652   s2 = R3.i;                                                            \
 653                                                                         \
 654   arg1._mp_alloc        = d1->words;                                    \
 655   arg1._mp_size         = (s1);                                         \
 656   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 657   arg2._mp_alloc        = d2->words;                                    \
 658   arg2._mp_size         = (s2);                                         \
 659   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 660                                                                         \
 661   STGCALL1(mpz_init,&result);                                           \
 662                                                                         \
 663   /* Perform the operation */                                           \
 664   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 665                                                                         \
 666   TICK_RET_UNBOXED_TUP(2);                                              \
 667   RET_NP(result._mp_size,                                               \
 668          result._mp_d-sizeofW(StgArrWords));                            \
 669   FE_                                                                   \
 670 }
 671
 672 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
 673 FN_(name)                                                               \
 674 {                                                                       \
 675   MP_INT arg1, result;                                                  \
 676   I_ s1;                                                                \
 677   StgArrWords* d1;                                                      \
 678   FB_                                                                   \
 679                                                                         \
 680   /* call doYouWantToGC() */                                            \
 681   MAYBE_GC(R2_PTR, name);                                               \
 682                                                                         \
 683   d1 = (StgArrWords *)R2.p;                                             \
 684   s1 = R1.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                                                                         \
 690   STGCALL1(mpz_init,&result);                                           \
 691                                                                         \
 692   /* Perform the operation */                                           \
 693   STGCALL2(mp_fun,&result,&arg1);                                       \
 694                                                                         \
 695   TICK_RET_UNBOXED_TUP(2);                                              \
 696   RET_NP(result._mp_size,                                               \
 697          result._mp_d-sizeofW(StgArrWords));                            \
 698   FE_                                                                   \
 699 }
 700
 701 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 702 FN_(name)                                                               \
 703 {                                                                       \
 704   MP_INT arg1, arg2, result1, result2;                                  \
 705   I_ s1, s2;                                                            \
 706   StgArrWords* d1;                                                      \
 707   StgArrWords* d2;                                                      \
 708   FB_                                                                   \
 709                                                                         \
 710   /* call doYouWantToGC() */                                            \
 711   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 712                                                                         \
 713   d1 = (StgArrWords *)R2.p;                                             \
 714   s1 = R1.i;                                                            \
 715   d2 = (StgArrWords *)R4.p;                                             \
 716   s2 = R3.i;                                                            \
 717                                                                         \
 718   arg1._mp_alloc        = d1->words;                                    \
 719   arg1._mp_size         = (s1);                                         \
 720   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 721   arg2._mp_alloc        = d2->words;                                    \
 722   arg2._mp_size         = (s2);                                         \
 723   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 724                                                                         \
 725   STGCALL1(mpz_init,&result1);                                          \
 726   STGCALL1(mpz_init,&result2);                                          \
 727                                                                         \
 728   /* Perform the operation */                                           \
 729   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 730                                                                         \
 731   TICK_RET_UNBOXED_TUP(4);                                              \
 732   RET_NPNP(result1._mp_size,                                            \
 733            result1._mp_d-sizeofW(StgArrWords),                          \
 734            result2._mp_size,                                            \
 735            result2._mp_d-sizeofW(StgArrWords));                         \
 736   FE_                                                                   \
 737 }
 738
 739 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 740 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 741 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 742 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 743 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 744 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 745 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 746 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and);
 747 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior);
 748 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor);
 749 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
 750
 751 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 752 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 753
 754 FN_(decodeFloatzh_fast)
 755 {
 756   MP_INT mantissa;
 757   I_ exponent;
 758   StgArrWords* p;
 759   StgFloat arg;
 760   FB_
 761
 762   /* arguments: F1 = Float# */
 763   arg = F1;
 764
 765   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 766   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 767   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 768
 769   /* Be prepared to tell Lennart-coded __decodeFloat    */
 770   /* where mantissa._mp_d can be put (it does not care about the rest) */
 771   p = (StgArrWords *)Hp - 1;
 772   SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
 773   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 774
 775   /* Perform the operation */
 776   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 777
 778   /* returns: (Int# (expn), Int#, ByteArray#) */
 779   TICK_RET_UNBOXED_TUP(3);
 780   RET_NNP(exponent,mantissa._mp_size,p);
 781   FE_
 782 }
 783
 784 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 785 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 786
 787 FN_(decodeDoublezh_fast)
 788 { MP_INT mantissa;
 789   I_ exponent;
 790   StgDouble arg;
 791   StgArrWords* p;
 792   FB_
 793
 794   /* arguments: D1 = Double# */
 795   arg = D1;
 796
 797   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 798   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 799   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 800
 801   /* Be prepared to tell Lennart-coded __decodeDouble   */
 802   /* where mantissa.d can be put (it does not care about the rest) */
 803   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 804   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 805   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 806
 807   /* Perform the operation */
 808   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 809
 810   /* returns: (Int# (expn), Int#, ByteArray#) */
 811   TICK_RET_UNBOXED_TUP(3);
 812   RET_NNP(exponent,mantissa._mp_size,p);
 813   FE_
 814 }
 815
 816 /* -----------------------------------------------------------------------------
 817  * Concurrency primitives
 818  * -------------------------------------------------------------------------- */
 819
 820 FN_(forkzh_fast)
 821 {
 822   FB_
 823   /* args: R1 = closure to spark */
 824
 825   MAYBE_GC(R1_PTR, forkzh_fast);
 826
 827   /* create it right now, return ThreadID in R1 */
 828   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 829                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 830   STGCALL1(scheduleThread, R1.t);
 831
 832   /* switch at the earliest opportunity */
 833   context_switch = 1;
 834
 835   JMP_(ENTRY_CODE(Sp[0]));
 836   FE_
 837 }
 838
 839 FN_(yieldzh_fast)
 840 {
 841   FB_
 842   JMP_(stg_yield_noregs);
 843   FE_
 844 }
 845
 846 /* -----------------------------------------------------------------------------
 847  * MVar primitives
 848  *
 849  * take & putMVar work as follows.  Firstly, an important invariant:
 850  *
 851  *    If the MVar is full, then the blocking queue contains only
 852  *    threads blocked on putMVar, and if the MVar is empty then the
 853  *    blocking queue contains only threads blocked on takeMVar.
 854  *
 855  * takeMvar:
 856  *    MVar empty : then add ourselves to the blocking queue
 857  *    MVar full  : remove the value from the MVar, and
 858  *                 blocking queue empty     : return
 859  *                 blocking queue non-empty : perform the first blocked putMVar
 860  *                                            from the queue, and wake up the
 861  *                                            thread (MVar is now full again)
 862  *
 863  * putMVar is just the dual of the above algorithm.
 864  *
 865  * How do we "perform a putMVar"?  Well, we have to fiddle around with
 866  * the stack of the thread waiting to do the putMVar.  See
 867  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
 868  * the stack layout, and the PerformPut and PerformTake macros below.
 869  *
 870  * It is important that a blocked take or put is woken up with the
 871  * take/put already performed, because otherwise there would be a
 872  * small window of vulnerability where the thread could receive an
 873  * exception and never perform its take or put, and we'd end up with a
 874  * deadlock.
 875  *
 876  * -------------------------------------------------------------------------- */
 877
 878 FN_(newMVarzh_fast)
 879 {
 880   StgMVar *mvar;
 881
 882   FB_
 883   /* args: none */
 884
 885   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 886   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 887                   1, 0);
 888   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 889
 890   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 891   SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
 892   mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 893   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 894
 895   TICK_RET_UNBOXED_TUP(1);
 896   RET_P(mvar);
 897   FE_
 898 }
 899
 900 #define PerformTake(tso, value) ({                      \
 901     (tso)->sp[1] = (W_)value;                           \
 902     (tso)->sp[0] = (W_)&stg_gc_unpt_r1_ret_info;        \
 903   })
 904
 905 #define PerformPut(tso) ({                              \
 906     StgClosure *val = (StgClosure *)(tso)->sp[2];       \
 907     (tso)->sp[2] = (W_)&stg_gc_noregs_ret_info;         \
 908     (tso)->sp += 2;                                     \
 909     val;                                                \
 910   })
 911
 912 FN_(takeMVarzh_fast)
 913 {
 914   StgMVar *mvar;
 915   StgClosure *val;
 916   const StgInfoTable *info;
 917
 918   FB_
 919   /* args: R1 = MVar closure */
 920
 921   mvar = (StgMVar *)R1.p;
 922
 923 #ifdef SMP
 924   info = LOCK_CLOSURE(mvar);
 925 #else
 926   info = GET_INFO(mvar);
 927 #endif
 928
 929   /* If the MVar is empty, put ourselves on its blocking queue,
 930    * and wait until we're woken up.
 931    */
 932   if (info == &stg_EMPTY_MVAR_info) {
 933     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 934       mvar->head = CurrentTSO;
 935     } else {
 936       mvar->tail->link = CurrentTSO;
 937     }
 938     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 939     CurrentTSO->why_blocked = BlockedOnMVar;
 940     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 941     mvar->tail = CurrentTSO;
 942
 943 #ifdef SMP
 944     /* unlock the MVar */
 945     mvar->header.info = &stg_EMPTY_MVAR_info;
 946 #endif
 947     JMP_(stg_block_takemvar);
 948   }
 949
 950   /* we got the value... */
 951   val = mvar->value;
 952
 953   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 954       /* There are putMVar(s) waiting...
 955        * wake up the first thread on the queue
 956        */
 957       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 958
 959       /* actually perform the putMVar for the thread that we just woke up */
 960       mvar->value = PerformPut(mvar->head);
 961
 962 #if defined(GRAN) || defined(PAR)
 963       /* ToDo: check 2nd arg (mvar) is right */
 964       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 965 #else
 966       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 967 #endif
 968       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 969           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 970       }
 971 #ifdef SMP
 972       /* unlock in the SMP case */
 973       SET_INFO(mvar,&stg_FULL_MVAR_info);
 974 #endif
 975       TICK_RET_UNBOXED_TUP(1);
 976       RET_P(val);
 977   } else {
 978       /* No further putMVars, MVar is now empty */
 979
 980       /* do this last... we might have locked the MVar in the SMP case,
 981        * and writing the info pointer will unlock it.
 982        */
 983       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 984       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 985       TICK_RET_UNBOXED_TUP(1);
 986       RET_P(val);
 987   }
 988   FE_
 989 }
 990
 991 FN_(tryTakeMVarzh_fast)
 992 {
 993   StgMVar *mvar;
 994   StgClosure *val;
 995   const StgInfoTable *info;
 996
 997   FB_
 998   /* args: R1 = MVar closure */
 999
1000   mvar = (StgMVar *)R1.p;
1001
1002 #ifdef SMP
1003   info = LOCK_CLOSURE(mvar);
1004 #else
1005   info = GET_INFO(mvar);
1006 #endif
1007
1008   if (info == &stg_EMPTY_MVAR_info) {
1009
1010 #ifdef SMP
1011       /* unlock the MVar */
1012       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1013 #endif
1014
1015       /* HACK: we need a pointer to pass back,
1016        * so we abuse NO_FINALIZER_closure
1017        */
1018       RET_NP(0, &stg_NO_FINALIZER_closure);
1019   }
1020
1021   /* we got the value... */
1022   val = mvar->value;
1023
1024   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1025       /* There are putMVar(s) waiting...
1026        * wake up the first thread on the queue
1027        */
1028       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1029
1030       /* actually perform the putMVar for the thread that we just woke up */
1031       mvar->value = PerformPut(mvar->head);
1032
1033 #if defined(GRAN) || defined(PAR)
1034       /* ToDo: check 2nd arg (mvar) is right */
1035       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1036 #else
1037       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1038 #endif
1039       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1040           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1041       }
1042 #ifdef SMP
1043       /* unlock in the SMP case */
1044       SET_INFO(mvar,&stg_FULL_MVAR_info);
1045 #endif
1046       TICK_RET_UNBOXED_TUP(1);
1047       RET_P(val);
1048   } else {
1049       /* No further putMVars, MVar is now empty */
1050
1051       /* do this last... we might have locked the MVar in the SMP case,
1052        * and writing the info pointer will unlock it.
1053        */
1054       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1055       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1056       TICK_RET_UNBOXED_TUP(1);
1057       RET_P(val);
1058   }
1059   FE_
1060 }
1061
1062 FN_(putMVarzh_fast)
1063 {
1064   StgMVar *mvar;
1065   const StgInfoTable *info;
1066
1067   FB_
1068   /* args: R1 = MVar, R2 = value */
1069
1070   mvar = (StgMVar *)R1.p;
1071
1072 #ifdef SMP
1073   info = LOCK_CLOSURE(mvar);
1074 #else
1075   info = GET_INFO(mvar);
1076 #endif
1077
1078   if (info == &stg_FULL_MVAR_info) {
1079     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1080       mvar->head = CurrentTSO;
1081     } else {
1082       mvar->tail->link = CurrentTSO;
1083     }
1084     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1085     CurrentTSO->why_blocked = BlockedOnMVar;
1086     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1087     mvar->tail = CurrentTSO;
1088
1089 #ifdef SMP
1090     /* unlock the MVar */
1091     SET_INFO(mvar,&stg_FULL_MVAR_info);
1092 #endif
1093     JMP_(stg_block_putmvar);
1094   }
1095
1096   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1097       /* There are takeMVar(s) waiting: wake up the first one
1098        */
1099       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1100
1101       /* actually perform the takeMVar */
1102       PerformTake(mvar->head, R2.cl);
1103
1104 #if defined(GRAN) || defined(PAR)
1105       /* ToDo: check 2nd arg (mvar) is right */
1106       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1107 #else
1108       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1109 #endif
1110       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1111           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1112       }
1113 #ifdef SMP
1114       /* unlocks the MVar in the SMP case */
1115       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1116 #endif
1117       JMP_(ENTRY_CODE(Sp[0]));
1118   } else {
1119       /* No further takes, the MVar is now full. */
1120       mvar->value = R2.cl;
1121       /* unlocks the MVar in the SMP case */
1122       SET_INFO(mvar,&stg_FULL_MVAR_info);
1123       JMP_(ENTRY_CODE(Sp[0]));
1124   }
1125
1126   /* ToDo: yield afterward for better communication performance? */
1127   FE_
1128 }
1129
1130 FN_(tryPutMVarzh_fast)
1131 {
1132   StgMVar *mvar;
1133   const StgInfoTable *info;
1134
1135   FB_
1136   /* args: R1 = MVar, R2 = value */
1137
1138   mvar = (StgMVar *)R1.p;
1139
1140 #ifdef SMP
1141   info = LOCK_CLOSURE(mvar);
1142 #else
1143   info = GET_INFO(mvar);
1144 #endif
1145
1146   if (info == &stg_FULL_MVAR_info) {
1147
1148 #ifdef SMP
1149     /* unlock the MVar */
1150     mvar->header.info = &stg_FULL_MVAR_info;
1151 #endif
1152
1153     RET_N(0);
1154   }
1155
1156   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1157       /* There are takeMVar(s) waiting: wake up the first one
1158        */
1159       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1160
1161       /* actually perform the takeMVar */
1162       PerformTake(mvar->head, R2.cl);
1163
1164 #if defined(GRAN) || defined(PAR)
1165       /* ToDo: check 2nd arg (mvar) is right */
1166       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1167 #else
1168       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1169 #endif
1170       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1171           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1172       }
1173 #ifdef SMP
1174       /* unlocks the MVar in the SMP case */
1175       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1176 #endif
1177       JMP_(ENTRY_CODE(Sp[0]));
1178   } else {
1179       /* No further takes, the MVar is now full. */
1180       mvar->value = R2.cl;
1181       /* unlocks the MVar in the SMP case */
1182       SET_INFO(mvar,&stg_FULL_MVAR_info);
1183       JMP_(ENTRY_CODE(Sp[0]));
1184   }
1185
1186   /* ToDo: yield afterward for better communication performance? */
1187   FE_
1188 }
1189
1190 /* -----------------------------------------------------------------------------
1191    Stable pointer primitives
1192    -------------------------------------------------------------------------  */
1193
1194 FN_(makeStableNamezh_fast)
1195 {
1196   StgWord index;
1197   StgStableName *sn_obj;
1198   FB_
1199
1200   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1201   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1202                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1203   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1204
1205   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1206
1207   /* Is there already a StableName for this heap object? */
1208   if (stable_ptr_table[index].sn_obj == NULL) {
1209     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1210     SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
1211     sn_obj->sn = index;
1212     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1213   } else {
1214     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1215   }
1216
1217   TICK_RET_UNBOXED_TUP(1);
1218   RET_P(sn_obj);
1219 }
1220
1221 /* -----------------------------------------------------------------------------
1222    Bytecode object primitives
1223    -------------------------------------------------------------------------  */
1224
1225 FN_(newBCOzh_fast)
1226 {
1227   /* R1.p = instrs
1228      R2.p = literals
1229      R3.p = ptrs
1230      R4.p = itbls
1231   */
1232   StgBCO *bco;
1233   FB_
1234
1235   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
1236   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1237   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1238   bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
1239   SET_HDR(bco, &stg_BCO_info, CCCS);
1240
1241   bco->instrs     = (StgArrWords*)R1.cl;
1242   bco->literals   = (StgArrWords*)R2.cl;
1243   bco->ptrs       = (StgMutArrPtrs*)R3.cl;
1244   bco->itbls      = (StgArrWords*)R4.cl;
1245
1246   TICK_RET_UNBOXED_TUP(1);
1247   RET_P(bco);
1248   FE_
1249 }
1250
1251 FN_(mkApUpd0zh_fast)
1252 {
1253   /* R1.p = the fn for the AP_UPD
1254   */
1255   StgAP_UPD* ap;
1256   FB_
1257   HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
1258   TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
1259   CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
1260   ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
1261   SET_HDR(ap, &stg_AP_UPD_info, CCCS);
1262
1263   ap->n_args = 0;
1264   ap->fun = R1.cl;
1265
1266   TICK_RET_UNBOXED_TUP(1);
1267   RET_P(ap);
1268   FE_
1269 }
1270
1271 /* -----------------------------------------------------------------------------
1272    Thread I/O blocking primitives
1273    -------------------------------------------------------------------------- */
1274
1275 FN_(waitReadzh_fast)
1276 {
1277   FB_
1278     /* args: R1.i */
1279     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1280     CurrentTSO->why_blocked = BlockedOnRead;
1281     CurrentTSO->block_info.fd = R1.i;
1282     ACQUIRE_LOCK(&sched_mutex);
1283     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1284     RELEASE_LOCK(&sched_mutex);
1285     JMP_(stg_block_noregs);
1286   FE_
1287 }
1288
1289 FN_(waitWritezh_fast)
1290 {
1291   FB_
1292     /* args: R1.i */
1293     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1294     CurrentTSO->why_blocked = BlockedOnWrite;
1295     CurrentTSO->block_info.fd = R1.i;
1296     ACQUIRE_LOCK(&sched_mutex);
1297     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1298     RELEASE_LOCK(&sched_mutex);
1299     JMP_(stg_block_noregs);
1300   FE_
1301 }
1302
1303 FN_(delayzh_fast)
1304 {
1305   StgTSO *t, *prev;
1306   nat target;
1307   FB_
1308     /* args: R1.i */
1309     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1310     CurrentTSO->why_blocked = BlockedOnDelay;
1311
1312     ACQUIRE_LOCK(&sched_mutex);
1313
1314     target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
1315     CurrentTSO->block_info.target = target;
1316
1317     /* Insert the new thread in the sleeping queue. */
1318     prev = NULL;
1319     t = sleeping_queue;
1320     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1321         prev = t;
1322         t = t->link;
1323     }
1324
1325     CurrentTSO->link = t;
1326     if (prev == NULL) {
1327         sleeping_queue = CurrentTSO;
1328     } else {
1329         prev->link = CurrentTSO;
1330     }
1331
1332     RELEASE_LOCK(&sched_mutex);
1333     JMP_(stg_block_noregs);
1334   FE_
1335 }
1336