ghc/rts/PrimOps.hc

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