ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.36 1999/12/08 14:21:52 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 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 712 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 713 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 714
 715 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 716 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 717
 718 #ifndef FLOATS_AS_DOUBLES
 719 FN_(decodeFloatzh_fast)
 720 {
 721   MP_INT mantissa;
 722   I_ exponent;
 723   StgArrWords* p;
 724   StgFloat arg;
 725   FB_
 726
 727   /* arguments: F1 = Float# */
 728   arg = F1;
 729
 730   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 731   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 732   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 733
 734   /* Be prepared to tell Lennart-coded __decodeFloat    */
 735   /* where mantissa._mp_d can be put (it does not care about the rest) */
 736   p = (StgArrWords *)Hp - 1;
 737   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 738   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 739
 740   /* Perform the operation */
 741   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 742
 743   /* returns: (Int# (expn), Int#, ByteArray#) */
 744   TICK_RET_UNBOXED_TUP(3);
 745   RET_NNP(exponent,mantissa._mp_size,p);
 746   FE_
 747 }
 748 #endif /* !FLOATS_AS_DOUBLES */
 749
 750 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 751 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 752
 753 FN_(decodeDoublezh_fast)
 754 { MP_INT mantissa;
 755   I_ exponent;
 756   StgDouble arg;
 757   StgArrWords* p;
 758   FB_
 759
 760   /* arguments: D1 = Double# */
 761   arg = D1;
 762
 763   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 764   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 765   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 766
 767   /* Be prepared to tell Lennart-coded __decodeDouble   */
 768   /* where mantissa.d can be put (it does not care about the rest) */
 769   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 770   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 771   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 772
 773   /* Perform the operation */
 774   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 775
 776   /* returns: (Int# (expn), Int#, ByteArray#) */
 777   TICK_RET_UNBOXED_TUP(3);
 778   RET_NNP(exponent,mantissa._mp_size,p);
 779   FE_
 780 }
 781
 782 /* -----------------------------------------------------------------------------
 783  * Concurrency primitives
 784  * -------------------------------------------------------------------------- */
 785
 786 FN_(forkzh_fast)
 787 {
 788   FB_
 789   /* args: R1 = closure to spark */
 790
 791   MAYBE_GC(R1_PTR, forkzh_fast);
 792
 793   /* create it right now, return ThreadID in R1 */
 794   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 795                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 796   STGCALL1(scheduleThread, R1.t);
 797
 798   /* switch at the earliest opportunity */
 799   context_switch = 1;
 800
 801   JMP_(ENTRY_CODE(Sp[0]));
 802   FE_
 803 }
 804
 805 FN_(yieldzh_fast)
 806 {
 807   FB_
 808   JMP_(stg_yield_noregs);
 809   FE_
 810 }
 811
 812 FN_(newMVarzh_fast)
 813 {
 814   StgMVar *mvar;
 815
 816   FB_
 817   /* args: none */
 818
 819   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 820   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 821                   1, 0);
 822   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 823
 824   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 825   SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
 826   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 827   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 828
 829   TICK_RET_UNBOXED_TUP(1);
 830   RET_P(mvar);
 831   FE_
 832 }
 833
 834 FN_(takeMVarzh_fast)
 835 {
 836   StgMVar *mvar;
 837   StgClosure *val;
 838   const StgInfoTable *info;
 839
 840   FB_
 841   /* args: R1 = MVar closure */
 842
 843   mvar = (StgMVar *)R1.p;
 844
 845 #ifdef SMP
 846   info = LOCK_CLOSURE(mvar);
 847 #else
 848   info = GET_INFO(mvar);
 849 #endif
 850
 851   /* If the MVar is empty, put ourselves on its blocking queue,
 852    * and wait until we're woken up.
 853    */
 854   if (info == &EMPTY_MVAR_info) {
 855     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 856       mvar->head = CurrentTSO;
 857     } else {
 858       mvar->tail->link = CurrentTSO;
 859     }
 860     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 861     CurrentTSO->why_blocked = BlockedOnMVar;
 862     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 863     mvar->tail = CurrentTSO;
 864
 865 #ifdef SMP
 866     /* unlock the MVar */
 867     mvar->header.info = &EMPTY_MVAR_info;
 868 #endif
 869     BLOCK(R1_PTR, takeMVarzh_fast);
 870   }
 871
 872   val = mvar->value;
 873   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 874
 875   /* do this last... we might have locked the MVar in the SMP case,
 876    * and writing the info pointer will unlock it.
 877    */
 878   SET_INFO(mvar,&EMPTY_MVAR_info);
 879
 880   TICK_RET_UNBOXED_TUP(1);
 881   RET_P(val);
 882   FE_
 883 }
 884
 885 FN_(putMVarzh_fast)
 886 {
 887   StgMVar *mvar;
 888   const StgInfoTable *info;
 889
 890   FB_
 891   /* args: R1 = MVar, R2 = value */
 892
 893   mvar = (StgMVar *)R1.p;
 894
 895 #ifdef SMP
 896   info = LOCK_CLOSURE(mvar);
 897 #else
 898   info = GET_INFO(mvar);
 899 #endif
 900
 901   if (info == &FULL_MVAR_info) {
 902     fprintf(stderr, "putMVar#: MVar already full.\n");
 903     stg_exit(EXIT_FAILURE);
 904   }
 905
 906   mvar->value = R2.cl;
 907
 908   /* wake up the first thread on the queue, it will continue with the
 909    * takeMVar operation and mark the MVar empty again.
 910    */
 911   if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
 912     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 913     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 914     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 915       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 916     }
 917   }
 918
 919   /* unlocks the MVar in the SMP case */
 920   SET_INFO(mvar,&FULL_MVAR_info);
 921
 922   /* ToDo: yield here for better communication performance? */
 923   JMP_(ENTRY_CODE(Sp[0]));
 924   FE_
 925 }
 926
 927 /* -----------------------------------------------------------------------------
 928    Stable pointer primitives
 929    -------------------------------------------------------------------------  */
 930
 931 FN_(makeStableNamezh_fast)
 932 {
 933   StgWord index;
 934   StgStableName *sn_obj;
 935   FB_
 936
 937   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 938   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 939                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
 940   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
 941
 942   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 943
 944   /* Is there already a StableName for this heap object? */
 945   if (stable_ptr_table[index].sn_obj == NULL) {
 946     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
 947     sn_obj->header.info = &STABLE_NAME_info;
 948     sn_obj->sn = index;
 949     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
 950   } else {
 951     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
 952   }
 953
 954   TICK_RET_UNBOXED_TUP(1);
 955   RET_P(sn_obj);
 956 }
 957
 958 /* -----------------------------------------------------------------------------
 959    Thread I/O blocking primitives
 960    -------------------------------------------------------------------------- */
 961
 962 FN_(waitReadzh_fast)
 963 {
 964   FB_
 965     /* args: R1.i */
 966     ASSERT(CurrentTSO->why_blocked == NotBlocked);
 967     CurrentTSO->why_blocked = BlockedOnRead;
 968     CurrentTSO->block_info.fd = R1.i;
 969     ACQUIRE_LOCK(&sched_mutex);
 970     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
 971     RELEASE_LOCK(&sched_mutex);
 972     JMP_(stg_block_noregs);
 973   FE_
 974 }
 975
 976 FN_(waitWritezh_fast)
 977 {
 978   FB_
 979     /* args: R1.i */
 980     ASSERT(CurrentTSO->why_blocked == NotBlocked);
 981     CurrentTSO->why_blocked = BlockedOnWrite;
 982     CurrentTSO->block_info.fd = R1.i;
 983     ACQUIRE_LOCK(&sched_mutex);
 984     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
 985     RELEASE_LOCK(&sched_mutex);
 986     JMP_(stg_block_noregs);
 987   FE_
 988 }
 989
 990 FN_(delayzh_fast)
 991 {
 992   FB_
 993     /* args: R1.i */
 994     ASSERT(CurrentTSO->why_blocked == NotBlocked);
 995     CurrentTSO->why_blocked = BlockedOnDelay;
 996
 997     ACQUIRE_LOCK(&sched_mutex);
 998
 999     /* Add on ticks_since_select, since these will be subtracted at
1000      * the next awaitEvent call.
1001      */
1002     CurrentTSO->block_info.delay = R1.i + ticks_since_select;
1003
1004     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1005
1006     RELEASE_LOCK(&sched_mutex);
1007     JMP_(stg_block_noregs);
1008   FE_
1009 }
1010
1011 #endif /* COMPILER */
1012