ghc/rts/PrimOps.hc

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