ghc/rts/PrimOps.hc

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