ghc/rts/PrimOps.hc

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