ghc/rts/PrimOps.hc

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