ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.90 2002/01/29 14:41:52 simonmar Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * Primitive functions / data
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Stg.h"
  11 #include "Rts.h"
  12
  13 #include "RtsFlags.h"
  14 #include "StgStartup.h"
  15 #include "SchedAPI.h"
  16 #include "Schedule.h"
  17 #include "RtsUtils.h"
  18 #include "Storage.h"
  19 #include "BlockAlloc.h" /* tmp */
  20 #include "StablePriv.h"
  21 #include "StgRun.h"
  22 #include "Itimer.h"
  23 #include "Prelude.h"
  24
  25 /* ** temporary **
  26
  27    classes CCallable and CReturnable don't really exist, but the
  28    compiler insists on generating dictionaries containing references
  29    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
  30    for these.  Some C compilers can't cope with zero-length static arrays,
  31    so we have to make these one element long.
  32 */
  33
  34 StgWord GHC_ZCCCallable_static_info[1];
  35 StgWord GHC_ZCCReturnable_static_info[1];
  36
  37 /* -----------------------------------------------------------------------------
  38    Macros for Hand-written primitives.
  39    -------------------------------------------------------------------------- */
  40
  41 /*
  42  * Horrible macros for returning unboxed tuples.
  43  *
  44  * How an unboxed tuple is returned depends on two factors:
  45  *    - the number of real registers we have available
  46  *    - the boxedness of the returned fields.
  47  *
  48  * To return an unboxed tuple from a primitive operation, we have macros
  49  * RET_<layout> where <layout> describes the boxedness of each field of the
  50  * unboxed tuple:  N indicates a non-pointer field, and P indicates a pointer.
  51  *
  52  * We only define the cases actually used, to avoid having too much
  53  * garbage in this section.  Warning: any bugs in here will be hard to
  54  * track down.
  55  */
  56
  57 /*------ All Regs available */
  58 #if defined(REG_R8)
  59 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  60 # define RET_N(a)     RET_P(a)
  61
  62 # define RET_PP(a,b)  R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
  63 # define RET_NN(a,b)  RET_PP(a,b)
  64 # define RET_NP(a,b)  RET_PP(a,b)
  65
  66 # define RET_PPP(a,b,c) \
  67         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
  68 # define RET_NNP(a,b,c) RET_PPP(a,b,c)
  69
  70 # define RET_NNNP(a,b,c,d) \
  71         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
  72         JMP_(ENTRY_CODE(Sp[0]));
  73
  74 # define RET_NPNP(a,b,c,d) \
  75         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
  76         JMP_(ENTRY_CODE(Sp[0]));
  77
  78 # define RET_NNPNNP(a,b,c,d,e,f) \
  79         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
  80         R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
  81         JMP_(ENTRY_CODE(Sp[0]));
  82
  83 #elif defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
  84       defined(REG_R4) || defined(REG_R3)
  85 # error RET_n macros not defined for this setup.
  86
  87 /*------ 2 Registers available */
  88 #elif defined(REG_R2)
  89
  90 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  91 # define RET_N(a)     RET_P(a)
  92
  93 # define RET_PP(a,b)   R1.w = (W_)(a); R2.w = (W_)(b); \
  94                        JMP_(ENTRY_CODE(Sp[0]));
  95 # define RET_NN(a,b)   RET_PP(a,b)
  96 # define RET_NP(a,b)   RET_PP(a,b)
  97
  98 # define RET_PPP(a,b,c) \
  99         R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
 100         JMP_(ENTRY_CODE(Sp[1]));
 101 # define RET_NNP(a,b,c) \
 102         R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
 103         JMP_(ENTRY_CODE(Sp[1]));
 104
 105 # define RET_NNNP(a,b,c,d)                      \
 106         R1.w = (W_)(a);                         \
 107         R2.w = (W_)(b);                         \
 108     /*  Sp[-3] = ARGTAG(1); */                  \
 109         Sp[-2] = (W_)(c);                       \
 110         Sp[-1] = (W_)(d);                       \
 111         Sp -= 3;                                \
 112         JMP_(ENTRY_CODE(Sp[3]));
 113
 114 # define RET_NPNP(a,b,c,d)                      \
 115         R1.w = (W_)(a);                         \
 116         R2.w = (W_)(b);                         \
 117     /*  Sp[-3] = ARGTAG(1); */                  \
 118         Sp[-2] = (W_)(c);                       \
 119         Sp[-1] = (W_)(d);                       \
 120         Sp -= 3;                                \
 121         JMP_(ENTRY_CODE(Sp[3]));
 122
 123 # define RET_NNPNNP(a,b,c,d,e,f)                \
 124         R1.w = (W_)(a);                         \
 125         R2.w = (W_)(b);                         \
 126         Sp[-6] = (W_)(c);                       \
 127         /* Sp[-5] = ARGTAG(1); */               \
 128         Sp[-4] = (W_)(d);                       \
 129         /* Sp[-3] = ARGTAG(1); */               \
 130         Sp[-2] = (W_)(e);                       \
 131         Sp[-1] = (W_)(f);                       \
 132         Sp -= 6;                                \
 133         JMP_(ENTRY_CODE(Sp[6]));
 134
 135 /*------ 1 Register available */
 136 #elif defined(REG_R1)
 137 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
 138 # define RET_N(a)     RET_P(a)
 139
 140 # define RET_PP(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
 141                        JMP_(ENTRY_CODE(Sp[1]));
 142 # define RET_NN(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
 143                        JMP_(ENTRY_CODE(Sp[2]));
 144 # define RET_NP(a,b)   RET_PP(a,b)
 145
 146 # define RET_PPP(a,b,c) \
 147         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
 148         JMP_(ENTRY_CODE(Sp[2]));
 149 # define RET_NNP(a,b,c) \
 150         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
 151         JMP_(ENTRY_CODE(Sp[3]));
 152
 153 # define RET_NNNP(a,b,c,d)                      \
 154         R1.w = (W_)(a);                         \
 155     /*  Sp[-5] = ARGTAG(1); */                  \
 156         Sp[-4] = (W_)(b);                       \
 157     /*  Sp[-3] = ARGTAG(1); */                  \
 158         Sp[-2] = (W_)(c);                       \
 159         Sp[-1] = (W_)(d);                       \
 160         Sp -= 5;                                \
 161         JMP_(ENTRY_CODE(Sp[5]));
 162
 163 # define RET_NPNP(a,b,c,d)                      \
 164         R1.w = (W_)(a);                         \
 165         Sp[-4] = (W_)(b);                       \
 166     /*  Sp[-3] = ARGTAG(1); */                  \
 167         Sp[-2] = (W_)(c);                       \
 168         Sp[-1] = (W_)(d);                       \
 169         Sp -= 4;                                \
 170         JMP_(ENTRY_CODE(Sp[4]));
 171
 172 # define RET_NNPNNP(a,b,c,d,e,f)                \
 173         R1.w = (W_)(a);                         \
 174         Sp[-1] = (W_)(f);                       \
 175         Sp[-2] = (W_)(e);                       \
 176         /* Sp[-3] = ARGTAG(1); */               \
 177         Sp[-4] = (W_)(d);                       \
 178         /* Sp[-5] = ARGTAG(1); */               \
 179         Sp[-6] = (W_)(c);                       \
 180         Sp[-7] = (W_)(b);                       \
 181         /* Sp[-8] = ARGTAG(1); */               \
 182         Sp -= 8;                                \
 183         JMP_(ENTRY_CODE(Sp[8]));
 184
 185 #else /* 0 Regs available */
 186
 187 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
 188
 189 #ifdef DEBUG
 190 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);  Sp[-o] = ARG_TAG(1);
 191 #else
 192 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);
 193 #endif
 194
 195 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 196
 197 /* Here's how to construct these macros:
 198  *
 199  *   N = number of N's in the name;
 200  *   P = number of P's in the name;
 201  *   s = N * 2 + P;
 202  *   while (nonNull(name)) {
 203  *     if (nextChar == 'P') {
 204  *       PUSH_P(s,_);
 205  *       s -= 1;
 206  *     } else {
 207  *       PUSH_N(s,_);
 208  *       s -= 2
 209  *     }
 210  *   }
 211  *   PUSHED(N * 2 + P);
 212  */
 213
 214 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 215 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 216
 217 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 218 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 219 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 220
 221 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 222 # define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
 223
 224 # define RET_NNNP(a,b,c,d) PUSH_N(7,a); PUSH_N(5,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(7)
 225 # define RET_NPNP(a,b,c,d) PUSH_N(6,a); PUSH_P(4,b); PUSH_N(3,c); PUSH_P(1,d); PUSHED(6)
 226 # define RET_NNPNNP(a,b,c,d,e,f) PUSH_N(10,a); PUSH_N(8,b); PUSH_P(6,c); PUSH_N(5,d); PUSH_N(3,e); PUSH_P(1,f); PUSHED(10)
 227
 228 #endif
 229
 230 /*-----------------------------------------------------------------------------
 231   Array Primitives
 232
 233   Basically just new*Array - the others are all inline macros.
 234
 235   The size arg is always passed in R1, and the result returned in R1.
 236
 237   The slow entry point is for returning from a heap check, the saved
 238   size argument must be re-loaded from the stack.
 239   -------------------------------------------------------------------------- */
 240
 241 /* for objects that are *less* than the size of a word, make sure we
 242  * round up to the nearest word for the size of the array.
 243  */
 244
 245 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 246
 247 FN_(newByteArrayzh_fast)                                \
 248  {                                                      \
 249    W_ size, stuff_size, n;                              \
 250    StgArrWords* p;                                      \
 251    FB_                                                  \
 252      MAYBE_GC(NO_PTRS,newByteArrayzh_fast);             \
 253      n = R1.w;                                          \
 254      stuff_size = BYTES_TO_STGWORDS(n);                 \
 255      size = sizeofW(StgArrWords)+ stuff_size;           \
 256      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 257      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 258      SET_HDR(p, &stg_ARR_WORDS_info, CCCS);             \
 259      p->words = stuff_size;                             \
 260      TICK_RET_UNBOXED_TUP(1)                            \
 261      RET_P(p);                                          \
 262    FE_                                                  \
 263  }
 264
 265 FN_(newPinnedByteArrayzh_fast)                                  \
 266  {                                                              \
 267    W_ size, stuff_size, n;                                      \
 268    StgArrWords* p;                                              \
 269    FB_                                                          \
 270      MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);               \
 271      n = R1.w;                                                  \
 272      stuff_size = BYTES_TO_STGWORDS(n);                         \
 273      size = sizeofW(StgArrWords)+ stuff_size;                   \
 274      p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size);   \
 275      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0);        \
 276      SET_HDR(p, &stg_ARR_WORDS_info, CCCS);                     \
 277      p->words = stuff_size;                                     \
 278      TICK_RET_UNBOXED_TUP(1)                                    \
 279      RET_P(p);                                                  \
 280    FE_                                                          \
 281  }
 282
 283 FN_(newArrayzh_fast)
 284 {
 285   W_ size, n, init;
 286   StgMutArrPtrs* arr;
 287   StgPtr p;
 288   FB_
 289     n = R1.w;
 290
 291     MAYBE_GC(R2_PTR,newArrayzh_fast);
 292
 293     size = sizeofW(StgMutArrPtrs) + n;
 294     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 295     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 296
 297     SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
 298     arr->ptrs = n;
 299
 300     init = R2.w;
 301     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 302          p < (P_)arr + size; p++) {
 303         *p = (W_)init;
 304     }
 305
 306     TICK_RET_UNBOXED_TUP(1);
 307     RET_P(arr);
 308   FE_
 309 }
 310
 311 FN_(newMutVarzh_fast)
 312 {
 313   StgMutVar* mv;
 314   /* Args: R1.p = initialisation value */
 315   FB_
 316
 317   HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 318   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 319   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 320
 321   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 322   SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
 323   mv->var = R1.cl;
 324
 325   TICK_RET_UNBOXED_TUP(1);
 326   RET_P(mv);
 327   FE_
 328 }
 329
 330 /* -----------------------------------------------------------------------------
 331    Foreign Object Primitives
 332    -------------------------------------------------------------------------- */
 333
 334 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, cmpIntegerzh_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_info;    \
1023   })
1024
1025 #define PerformPut(tso) ({                              \
1026     StgClosure *val = (StgClosure *)(tso)->sp[2];       \
1027     (tso)->sp[2] = (W_)&stg_gc_noregs_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   } else {
1167       /* No further putMVars, MVar is now empty */
1168       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1169
1170       /* do this last... we might have locked the MVar in the SMP case,
1171        * and writing the info pointer will unlock it.
1172        */
1173       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1174   }
1175
1176   TICK_RET_UNBOXED_TUP(1);
1177   RET_NP((I_)1, val);
1178   FE_
1179 }
1180
1181 FN_(putMVarzh_fast)
1182 {
1183   StgMVar *mvar;
1184   const StgInfoTable *info;
1185
1186   FB_
1187   /* args: R1 = MVar, R2 = value */
1188
1189   mvar = (StgMVar *)R1.p;
1190
1191 #ifdef SMP
1192   info = LOCK_CLOSURE(mvar);
1193 #else
1194   info = GET_INFO(mvar);
1195 #endif
1196
1197   if (info == &stg_FULL_MVAR_info) {
1198     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1199       mvar->head = CurrentTSO;
1200     } else {
1201       mvar->tail->link = CurrentTSO;
1202     }
1203     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1204     CurrentTSO->why_blocked = BlockedOnMVar;
1205     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1206     mvar->tail = CurrentTSO;
1207
1208 #ifdef SMP
1209     /* unlock the MVar */
1210     SET_INFO(mvar,&stg_FULL_MVAR_info);
1211 #endif
1212     JMP_(stg_block_putmvar);
1213   }
1214
1215   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1216       /* There are takeMVar(s) waiting: wake up the first one
1217        */
1218       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1219
1220       /* actually perform the takeMVar */
1221       PerformTake(mvar->head, R2.cl);
1222
1223 #if defined(GRAN) || defined(PAR)
1224       /* ToDo: check 2nd arg (mvar) is right */
1225       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1226 #else
1227       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1228 #endif
1229       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1230           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1231       }
1232 #ifdef SMP
1233       /* unlocks the MVar in the SMP case */
1234       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1235 #endif
1236       JMP_(ENTRY_CODE(Sp[0]));
1237   } else {
1238       /* No further takes, the MVar is now full. */
1239       mvar->value = R2.cl;
1240       /* unlocks the MVar in the SMP case */
1241       SET_INFO(mvar,&stg_FULL_MVAR_info);
1242       JMP_(ENTRY_CODE(Sp[0]));
1243   }
1244
1245   /* ToDo: yield afterward for better communication performance? */
1246   FE_
1247 }
1248
1249 FN_(tryPutMVarzh_fast)
1250 {
1251   StgMVar *mvar;
1252   const StgInfoTable *info;
1253
1254   FB_
1255   /* args: R1 = MVar, R2 = value */
1256
1257   mvar = (StgMVar *)R1.p;
1258
1259 #ifdef SMP
1260   info = LOCK_CLOSURE(mvar);
1261 #else
1262   info = GET_INFO(mvar);
1263 #endif
1264
1265   if (info == &stg_FULL_MVAR_info) {
1266
1267 #ifdef SMP
1268     /* unlock the MVar */
1269     mvar->header.info = &stg_FULL_MVAR_info;
1270 #endif
1271
1272     RET_N(0);
1273   }
1274
1275   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1276       /* There are takeMVar(s) waiting: wake up the first one
1277        */
1278       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1279
1280       /* actually perform the takeMVar */
1281       PerformTake(mvar->head, R2.cl);
1282
1283 #if defined(GRAN) || defined(PAR)
1284       /* ToDo: check 2nd arg (mvar) is right */
1285       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1286 #else
1287       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1288 #endif
1289       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1290           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1291       }
1292 #ifdef SMP
1293       /* unlocks the MVar in the SMP case */
1294       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1295 #endif
1296       JMP_(ENTRY_CODE(Sp[0]));
1297   } else {
1298       /* No further takes, the MVar is now full. */
1299       mvar->value = R2.cl;
1300       /* unlocks the MVar in the SMP case */
1301       SET_INFO(mvar,&stg_FULL_MVAR_info);
1302       JMP_(ENTRY_CODE(Sp[0]));
1303   }
1304
1305   /* ToDo: yield afterward for better communication performance? */
1306   FE_
1307 }
1308
1309 /* -----------------------------------------------------------------------------
1310    Stable pointer primitives
1311    -------------------------------------------------------------------------  */
1312
1313 FN_(makeStableNamezh_fast)
1314 {
1315   StgWord index;
1316   StgStableName *sn_obj;
1317   FB_
1318
1319   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1320   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1321                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1322   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1323
1324   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1325
1326   /* Is there already a StableName for this heap object? */
1327   if (stable_ptr_table[index].sn_obj == NULL) {
1328     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1329     SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
1330     sn_obj->sn = index;
1331     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1332   } else {
1333     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1334   }
1335
1336   TICK_RET_UNBOXED_TUP(1);
1337   RET_P(sn_obj);
1338 }
1339
1340
1341 FN_(makeStablePtrzh_fast)
1342 {
1343   /* Args: R1 = a */
1344   StgStablePtr sp;
1345   FB_
1346   MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1347   sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p);
1348   RET_N(sp);
1349   FE_
1350 }
1351
1352 FN_(deRefStablePtrzh_fast)
1353 {
1354   /* Args: R1 = the stable ptr */
1355   P_ r;
1356   StgStablePtr sp;
1357   FB_
1358   sp = (StgStablePtr)R1.w;
1359   r = stable_ptr_table[(StgWord)sp].addr;
1360   RET_P(r);
1361   FE_
1362 }
1363
1364 /* -----------------------------------------------------------------------------
1365    Bytecode object primitives
1366    -------------------------------------------------------------------------  */
1367
1368 FN_(newBCOzh_fast)
1369 {
1370   /* R1.p = instrs
1371      R2.p = literals
1372      R3.p = ptrs
1373      R4.p = itbls
1374   */
1375   StgBCO *bco;
1376   FB_
1377
1378   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
1379   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1380   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1381   bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
1382   SET_HDR(bco, &stg_BCO_info, CCCS);
1383
1384   bco->instrs     = (StgArrWords*)R1.cl;
1385   bco->literals   = (StgArrWords*)R2.cl;
1386   bco->ptrs       = (StgMutArrPtrs*)R3.cl;
1387   bco->itbls      = (StgArrWords*)R4.cl;
1388
1389   TICK_RET_UNBOXED_TUP(1);
1390   RET_P(bco);
1391   FE_
1392 }
1393
1394 FN_(mkApUpd0zh_fast)
1395 {
1396   /* R1.p = the fn for the AP_UPD
1397   */
1398   StgAP_UPD* ap;
1399   FB_
1400   HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
1401   TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
1402   CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
1403   ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
1404   SET_HDR(ap, &stg_AP_UPD_info, CCCS);
1405
1406   ap->n_args = 0;
1407   ap->fun = R1.cl;
1408
1409   TICK_RET_UNBOXED_TUP(1);
1410   RET_P(ap);
1411   FE_
1412 }
1413
1414 /* -----------------------------------------------------------------------------
1415    Thread I/O blocking primitives
1416    -------------------------------------------------------------------------- */
1417
1418 FN_(waitReadzh_fast)
1419 {
1420   FB_
1421     /* args: R1.i */
1422     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1423     CurrentTSO->why_blocked = BlockedOnRead;
1424     CurrentTSO->block_info.fd = R1.i;
1425     ACQUIRE_LOCK(&sched_mutex);
1426     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1427     RELEASE_LOCK(&sched_mutex);
1428     JMP_(stg_block_noregs);
1429   FE_
1430 }
1431
1432 FN_(waitWritezh_fast)
1433 {
1434   FB_
1435     /* args: R1.i */
1436     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1437     CurrentTSO->why_blocked = BlockedOnWrite;
1438     CurrentTSO->block_info.fd = R1.i;
1439     ACQUIRE_LOCK(&sched_mutex);
1440     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1441     RELEASE_LOCK(&sched_mutex);
1442     JMP_(stg_block_noregs);
1443   FE_
1444 }
1445
1446 FN_(delayzh_fast)
1447 {
1448   StgTSO *t, *prev;
1449   nat target;
1450   FB_
1451     /* args: R1.i */
1452     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1453     CurrentTSO->why_blocked = BlockedOnDelay;
1454
1455     ACQUIRE_LOCK(&sched_mutex);
1456
1457     target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
1458     CurrentTSO->block_info.target = target;
1459
1460     /* Insert the new thread in the sleeping queue. */
1461     prev = NULL;
1462     t = sleeping_queue;
1463     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1464         prev = t;
1465         t = t->link;
1466     }
1467
1468     CurrentTSO->link = t;
1469     if (prev == NULL) {
1470         sleeping_queue = CurrentTSO;
1471     } else {
1472         prev->link = CurrentTSO;
1473     }
1474
1475     RELEASE_LOCK(&sched_mutex);
1476     JMP_(stg_block_noregs);
1477   FE_
1478 }
1479