ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.81 2001/07/23 17:28:33 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 /* -----------------------------------------------------------------------------
 812  * MVar primitives
 813  *
 814  * take & putMVar work as follows.  Firstly, an important invariant:
 815  *
 816  *    If the MVar is full, then the blocking queue contains only
 817  *    threads blocked on putMVar, and if the MVar is empty then the
 818  *    blocking queue contains only threads blocked on takeMVar.
 819  *
 820  * takeMvar:
 821  *    MVar empty : then add ourselves to the blocking queue
 822  *    MVar full  : remove the value from the MVar, and
 823  *                 blocking queue empty     : return
 824  *                 blocking queue non-empty : perform the first blocked putMVar
 825  *                                            from the queue, and wake up the
 826  *                                            thread (MVar is now full again)
 827  *
 828  * putMVar is just the dual of the above algorithm.
 829  *
 830  * How do we "perform a putMVar"?  Well, we have to fiddle around with
 831  * the stack of the thread waiting to do the putMVar.  See
 832  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
 833  * the stack layout, and the PerformPut and PerformTake macros below.
 834  *
 835  * It is important that a blocked take or put is woken up with the
 836  * take/put already performed, because otherwise there would be a
 837  * small window of vulnerability where the thread could receive an
 838  * exception and never perform its take or put, and we'd end up with a
 839  * deadlock.
 840  *
 841  * -------------------------------------------------------------------------- */
 842
 843 FN_(newMVarzh_fast)
 844 {
 845   StgMVar *mvar;
 846
 847   FB_
 848   /* args: none */
 849
 850   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 851   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 852                   1, 0);
 853   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 854
 855   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 856   SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
 857   mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 858   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 859
 860   TICK_RET_UNBOXED_TUP(1);
 861   RET_P(mvar);
 862   FE_
 863 }
 864
 865 #define PerformTake(tso, value) ({                      \
 866     (tso)->sp[1] = (W_)value;                           \
 867     (tso)->sp[0] = (W_)&stg_gc_unpt_r1_ret_info;        \
 868   })
 869
 870 #define PerformPut(tso) ({                              \
 871     StgClosure *val = (StgClosure *)(tso)->sp[2];       \
 872     (tso)->sp[2] = (W_)&stg_gc_noregs_ret_info;         \
 873     (tso)->sp += 2;                                     \
 874     val;                                                \
 875   })
 876
 877 FN_(takeMVarzh_fast)
 878 {
 879   StgMVar *mvar;
 880   StgClosure *val;
 881   const StgInfoTable *info;
 882
 883   FB_
 884   /* args: R1 = MVar closure */
 885
 886   mvar = (StgMVar *)R1.p;
 887
 888 #ifdef SMP
 889   info = LOCK_CLOSURE(mvar);
 890 #else
 891   info = GET_INFO(mvar);
 892 #endif
 893
 894   /* If the MVar is empty, put ourselves on its blocking queue,
 895    * and wait until we're woken up.
 896    */
 897   if (info == &stg_EMPTY_MVAR_info) {
 898     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 899       mvar->head = CurrentTSO;
 900     } else {
 901       mvar->tail->link = CurrentTSO;
 902     }
 903     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 904     CurrentTSO->why_blocked = BlockedOnMVar;
 905     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 906     mvar->tail = CurrentTSO;
 907
 908 #ifdef SMP
 909     /* unlock the MVar */
 910     mvar->header.info = &stg_EMPTY_MVAR_info;
 911 #endif
 912     JMP_(stg_block_takemvar);
 913   }
 914
 915   /* we got the value... */
 916   val = mvar->value;
 917
 918   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 919       /* There are putMVar(s) waiting...
 920        * wake up the first thread on the queue
 921        */
 922       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 923
 924       /* actually perform the putMVar for the thread that we just woke up */
 925       mvar->value = PerformPut(mvar->head);
 926
 927 #if defined(GRAN) || defined(PAR)
 928       /* ToDo: check 2nd arg (mvar) is right */
 929       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 930 #else
 931       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 932 #endif
 933       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 934           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 935       }
 936 #ifdef SMP
 937       /* unlock in the SMP case */
 938       SET_INFO(mvar,&stg_FULL_MVAR_info);
 939 #endif
 940       TICK_RET_UNBOXED_TUP(1);
 941       RET_P(val);
 942   } else {
 943       /* No further putMVars, MVar is now empty */
 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       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 950       TICK_RET_UNBOXED_TUP(1);
 951       RET_P(val);
 952   }
 953   FE_
 954 }
 955
 956 FN_(tryTakeMVarzh_fast)
 957 {
 958   StgMVar *mvar;
 959   StgClosure *val;
 960   const StgInfoTable *info;
 961
 962   FB_
 963   /* args: R1 = MVar closure */
 964
 965   mvar = (StgMVar *)R1.p;
 966
 967 #ifdef SMP
 968   info = LOCK_CLOSURE(mvar);
 969 #else
 970   info = GET_INFO(mvar);
 971 #endif
 972
 973   if (info == &stg_EMPTY_MVAR_info) {
 974
 975 #ifdef SMP
 976       /* unlock the MVar */
 977       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 978 #endif
 979
 980       /* HACK: we need a pointer to pass back,
 981        * so we abuse NO_FINALIZER_closure
 982        */
 983       RET_NP(0, &stg_NO_FINALIZER_closure);
 984   }
 985
 986   /* we got the value... */
 987   val = mvar->value;
 988
 989   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 990       /* There are putMVar(s) waiting...
 991        * wake up the first thread on the queue
 992        */
 993       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 994
 995       /* actually perform the putMVar for the thread that we just woke up */
 996       mvar->value = PerformPut(mvar->head);
 997
 998 #if defined(GRAN) || defined(PAR)
 999       /* ToDo: check 2nd arg (mvar) is right */
1000       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1001 #else
1002       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1003 #endif
1004       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1005           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1006       }
1007 #ifdef SMP
1008       /* unlock in the SMP case */
1009       SET_INFO(mvar,&stg_FULL_MVAR_info);
1010 #endif
1011       TICK_RET_UNBOXED_TUP(1);
1012       RET_P(val);
1013   } else {
1014       /* No further putMVars, MVar is now empty */
1015
1016       /* do this last... we might have locked the MVar in the SMP case,
1017        * and writing the info pointer will unlock it.
1018        */
1019       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1020       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1021       TICK_RET_UNBOXED_TUP(1);
1022       RET_P(val);
1023   }
1024   FE_
1025 }
1026
1027 FN_(putMVarzh_fast)
1028 {
1029   StgMVar *mvar;
1030   const StgInfoTable *info;
1031
1032   FB_
1033   /* args: R1 = MVar, R2 = value */
1034
1035   mvar = (StgMVar *)R1.p;
1036
1037 #ifdef SMP
1038   info = LOCK_CLOSURE(mvar);
1039 #else
1040   info = GET_INFO(mvar);
1041 #endif
1042
1043   if (info == &stg_FULL_MVAR_info) {
1044     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1045       mvar->head = CurrentTSO;
1046     } else {
1047       mvar->tail->link = CurrentTSO;
1048     }
1049     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1050     CurrentTSO->why_blocked = BlockedOnMVar;
1051     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1052     mvar->tail = CurrentTSO;
1053
1054 #ifdef SMP
1055     /* unlock the MVar */
1056     SET_INFO(mvar,&stg_FULL_MVAR_info);
1057 #endif
1058     JMP_(stg_block_putmvar);
1059   }
1060
1061   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1062       /* There are takeMVar(s) waiting: wake up the first one
1063        */
1064       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1065
1066       /* actually perform the takeMVar */
1067       PerformTake(mvar->head, R2.cl);
1068
1069 #if defined(GRAN) || defined(PAR)
1070       /* ToDo: check 2nd arg (mvar) is right */
1071       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1072 #else
1073       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1074 #endif
1075       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1076           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1077       }
1078 #ifdef SMP
1079       /* unlocks the MVar in the SMP case */
1080       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1081 #endif
1082       JMP_(ENTRY_CODE(Sp[0]));
1083   } else {
1084       /* No further takes, the MVar is now full. */
1085       mvar->value = R2.cl;
1086       /* unlocks the MVar in the SMP case */
1087       SET_INFO(mvar,&stg_FULL_MVAR_info);
1088       JMP_(ENTRY_CODE(Sp[0]));
1089   }
1090
1091   /* ToDo: yield afterward for better communication performance? */
1092   FE_
1093 }
1094
1095 FN_(tryPutMVarzh_fast)
1096 {
1097   StgMVar *mvar;
1098   const StgInfoTable *info;
1099
1100   FB_
1101   /* args: R1 = MVar, R2 = value */
1102
1103   mvar = (StgMVar *)R1.p;
1104
1105 #ifdef SMP
1106   info = LOCK_CLOSURE(mvar);
1107 #else
1108   info = GET_INFO(mvar);
1109 #endif
1110
1111   if (info == &stg_FULL_MVAR_info) {
1112
1113 #ifdef SMP
1114     /* unlock the MVar */
1115     mvar->header.info = &stg_FULL_MVAR_info;
1116 #endif
1117
1118     RET_N(0);
1119   }
1120
1121   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1122       /* There are takeMVar(s) waiting: wake up the first one
1123        */
1124       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1125
1126       /* actually perform the takeMVar */
1127       PerformTake(mvar->head, R2.cl);
1128
1129 #if defined(GRAN) || defined(PAR)
1130       /* ToDo: check 2nd arg (mvar) is right */
1131       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1132 #else
1133       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1134 #endif
1135       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1136           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1137       }
1138 #ifdef SMP
1139       /* unlocks the MVar in the SMP case */
1140       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1141 #endif
1142       JMP_(ENTRY_CODE(Sp[0]));
1143   } else {
1144       /* No further takes, the MVar is now full. */
1145       mvar->value = R2.cl;
1146       /* unlocks the MVar in the SMP case */
1147       SET_INFO(mvar,&stg_FULL_MVAR_info);
1148       JMP_(ENTRY_CODE(Sp[0]));
1149   }
1150
1151   /* ToDo: yield afterward for better communication performance? */
1152   FE_
1153 }
1154
1155 /* -----------------------------------------------------------------------------
1156    Stable pointer primitives
1157    -------------------------------------------------------------------------  */
1158
1159 FN_(makeStableNamezh_fast)
1160 {
1161   StgWord index;
1162   StgStableName *sn_obj;
1163   FB_
1164
1165   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1166   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1167                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1168   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1169
1170   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1171
1172   /* Is there already a StableName for this heap object? */
1173   if (stable_ptr_table[index].sn_obj == NULL) {
1174     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1175     SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
1176     sn_obj->sn = index;
1177     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1178   } else {
1179     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1180   }
1181
1182   TICK_RET_UNBOXED_TUP(1);
1183   RET_P(sn_obj);
1184 }
1185
1186 /* -----------------------------------------------------------------------------
1187    Bytecode object primitives
1188    -------------------------------------------------------------------------  */
1189
1190 FN_(newBCOzh_fast)
1191 {
1192   /* R1.p = instrs
1193      R2.p = literals
1194      R3.p = ptrs
1195      R4.p = itbls
1196   */
1197   StgBCO *bco;
1198   FB_
1199
1200   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
1201   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1202   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1203   bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
1204   SET_HDR(bco, &stg_BCO_info, CCCS);
1205
1206   bco->instrs     = (StgArrWords*)R1.cl;
1207   bco->literals   = (StgArrWords*)R2.cl;
1208   bco->ptrs       = (StgMutArrPtrs*)R3.cl;
1209   bco->itbls      = (StgArrWords*)R4.cl;
1210
1211   TICK_RET_UNBOXED_TUP(1);
1212   RET_P(bco);
1213   FE_
1214 }
1215
1216 FN_(mkApUpd0zh_fast)
1217 {
1218   /* R1.p = the fn for the AP_UPD
1219   */
1220   StgAP_UPD* ap;
1221   FB_
1222   HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
1223   TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
1224   CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
1225   ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
1226   SET_HDR(ap, &stg_AP_UPD_info, CCCS);
1227
1228   ap->n_args = 0;
1229   ap->fun = R1.cl;
1230
1231   TICK_RET_UNBOXED_TUP(1);
1232   RET_P(ap);
1233   FE_
1234 }
1235
1236 /* -----------------------------------------------------------------------------
1237    Thread I/O blocking primitives
1238    -------------------------------------------------------------------------- */
1239
1240 FN_(waitReadzh_fast)
1241 {
1242   FB_
1243     /* args: R1.i */
1244     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1245     CurrentTSO->why_blocked = BlockedOnRead;
1246     CurrentTSO->block_info.fd = R1.i;
1247     ACQUIRE_LOCK(&sched_mutex);
1248     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1249     RELEASE_LOCK(&sched_mutex);
1250     JMP_(stg_block_noregs);
1251   FE_
1252 }
1253
1254 FN_(waitWritezh_fast)
1255 {
1256   FB_
1257     /* args: R1.i */
1258     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1259     CurrentTSO->why_blocked = BlockedOnWrite;
1260     CurrentTSO->block_info.fd = R1.i;
1261     ACQUIRE_LOCK(&sched_mutex);
1262     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1263     RELEASE_LOCK(&sched_mutex);
1264     JMP_(stg_block_noregs);
1265   FE_
1266 }
1267
1268 FN_(delayzh_fast)
1269 {
1270   StgTSO *t, *prev;
1271   nat target;
1272   FB_
1273     /* args: R1.i */
1274     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1275     CurrentTSO->why_blocked = BlockedOnDelay;
1276
1277     ACQUIRE_LOCK(&sched_mutex);
1278
1279     target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
1280     CurrentTSO->block_info.target = target;
1281
1282     /* Insert the new thread in the sleeping queue. */
1283     prev = NULL;
1284     t = sleeping_queue;
1285     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1286         prev = t;
1287         t = t->link;
1288     }
1289
1290     CurrentTSO->link = t;
1291     if (prev == NULL) {
1292         sleeping_queue = CurrentTSO;
1293     } else {
1294         prev->link = CurrentTSO;
1295     }
1296
1297     RELEASE_LOCK(&sched_mutex);
1298     JMP_(stg_block_noregs);
1299   FE_
1300 }
1301