ghc/rts/PrimOps.hc

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