ghc/rts/PrimOps.hc

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