ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.55 2000/09/26 16:45:35 simonpj Exp $
   3  *
   4  * (c) The GHC Team, 1998-2000
   5  *
   6  * Primitive functions / data
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #include "Rts.h"
  11
  12 #include "RtsFlags.h"
  13 #include "StgStartup.h"
  14 #include "SchedAPI.h"
  15 #include "Schedule.h"
  16 #include "RtsUtils.h"
  17 #include "Storage.h"
  18 #include "BlockAlloc.h" /* tmp */
  19 #include "StablePriv.h"
  20 #include "HeapStackCheck.h"
  21 #include "StgRun.h"
  22 #include "Itimer.h"
  23 #include "Prelude.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
 189 #ifdef DEBUG
 190 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);  Sp[-o] = ARG_TAG(1);
 191 #else
 192 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);
 193 #endif
 194
 195 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 196
 197 /* Here's how to construct these macros:
 198  *
 199  *   N = number of N's in the name;
 200  *   P = number of P's in the name;
 201  *   s = N * 2 + P;
 202  *   while (nonNull(name)) {
 203  *     if (nextChar == 'P') {
 204  *       PUSH_P(s,_);
 205  *       s -= 1;
 206  *     } else {
 207  *       PUSH_N(s,_);
 208  *       s -= 2
 209  *     }
 210  *   }
 211  *   PUSHED(N * 2 + P);
 212  */
 213
 214 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 215 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 216
 217 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 218 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 219 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 220
 221 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 222 # define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
 223
 224 # 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)
 225 # 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)
 226 # 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)
 227
 228 #endif
 229
 230 /*-----------------------------------------------------------------------------
 231   Array Primitives
 232
 233   Basically just new*Array - the others are all inline macros.
 234
 235   The size arg is always passed in R1, and the result returned in R1.
 236
 237   The slow entry point is for returning from a heap check, the saved
 238   size argument must be re-loaded from the stack.
 239   -------------------------------------------------------------------------- */
 240
 241 /* for objects that are *less* than the size of a word, make sure we
 242  * round up to the nearest word for the size of the array.
 243  */
 244
 245 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 246
 247 #define newByteArray(ty,scale)                          \
 248  FN_(new##ty##Arrayzh_fast)                             \
 249  {                                                      \
 250    W_ stuff_size, size, n;                              \
 251    StgArrWords* p;                                      \
 252    FB_                                                  \
 253      MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast);           \
 254      n = R1.w;                                          \
 255      stuff_size = BYTES_TO_STGWORDS(n*scale);           \
 256      size = sizeofW(StgArrWords)+ stuff_size;           \
 257      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 258      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 259      SET_HDR(p, &ARR_WORDS_info, CCCS);         \
 260      p->words = stuff_size;                             \
 261      TICK_RET_UNBOXED_TUP(1)                            \
 262      RET_P(p);                                          \
 263    FE_                                                  \
 264  }
 265
 266 newByteArray(Char,   1)
 267 /* Char arrays really contain only 8-bit bytes for compatibility. */
 268 newByteArray(Int,    sizeof(I_))
 269 newByteArray(Word,   sizeof(W_))
 270 newByteArray(Addr,   sizeof(P_))
 271 newByteArray(Float,  sizeof(StgFloat))
 272 newByteArray(Double, sizeof(StgDouble))
 273 newByteArray(StablePtr, sizeof(StgStablePtr))
 274
 275 FN_(newArrayzh_fast)
 276 {
 277   W_ size, n, init;
 278   StgMutArrPtrs* arr;
 279   StgPtr p;
 280   FB_
 281     n = R1.w;
 282
 283     MAYBE_GC(R2_PTR,newArrayzh_fast);
 284
 285     size = sizeofW(StgMutArrPtrs) + n;
 286     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 287     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 288
 289     SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
 290     arr->ptrs = n;
 291
 292     init = R2.w;
 293     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 294          p < (P_)arr + size; p++) {
 295         *p = (W_)init;
 296     }
 297
 298     TICK_RET_UNBOXED_TUP(1);
 299     RET_P(arr);
 300   FE_
 301 }
 302
 303 FN_(newMutVarzh_fast)
 304 {
 305   StgMutVar* mv;
 306   /* Args: R1.p = initialisation value */
 307   FB_
 308
 309   HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 310   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 311   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 312
 313   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 314   SET_HDR(mv,&MUT_VAR_info,CCCS);
 315   mv->var = R1.cl;
 316
 317   TICK_RET_UNBOXED_TUP(1);
 318   RET_P(mv);
 319   FE_
 320 }
 321
 322 /* -----------------------------------------------------------------------------
 323    Foreign Object Primitives
 324
 325    -------------------------------------------------------------------------- */
 326
 327 #ifndef PAR
 328 FN_(mkForeignObjzh_fast)
 329 {
 330   /* R1.p = ptr to foreign object,
 331   */
 332   StgForeignObj *result;
 333   FB_
 334
 335   HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast,);
 336   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 337                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 338   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 339
 340   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 341   SET_HDR(result,&FOREIGN_info,CCCS);
 342   result->data = R1.p;
 343
 344   /* returns (# s#, ForeignObj# #) */
 345   TICK_RET_UNBOXED_TUP(1);
 346   RET_P(result);
 347   FE_
 348 }
 349 #endif
 350
 351 /* These two are out-of-line for the benefit of the NCG */
 352 FN_(unsafeThawArrayzh_fast)
 353 {
 354   FB_
 355   SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
 356   recordMutable((StgMutClosure*)R1.cl);
 357
 358   TICK_RET_UNBOXED_TUP(1);
 359   RET_P(R1.p);
 360   FE_
 361 }
 362
 363 /* -----------------------------------------------------------------------------
 364    Weak Pointer Primitives
 365    -------------------------------------------------------------------------- */
 366
 367 #ifndef PAR
 368
 369 FN_(mkWeakzh_fast)
 370 {
 371   /* R1.p = key
 372      R2.p = value
 373      R3.p = finalizer (or NULL)
 374   */
 375   StgWeak *w;
 376   FB_
 377
 378   if (R3.cl == NULL) {
 379     R3.cl = &NO_FINALIZER_closure;
 380   }
 381
 382   HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 383   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 384                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 385   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 386
 387   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 388   SET_HDR(w, &WEAK_info, CCCS);
 389
 390   w->key        = R1.cl;
 391   w->value      = R2.cl;
 392   w->finalizer  = R3.cl;
 393
 394   w->link       = weak_ptr_list;
 395   weak_ptr_list = w;
 396   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 397
 398   TICK_RET_UNBOXED_TUP(1);
 399   RET_P(w);
 400   FE_
 401 }
 402
 403 FN_(finalizzeWeakzh_fast)
 404 {
 405   /* R1.p = weak ptr
 406    */
 407   StgDeadWeak *w;
 408   StgClosure *f;
 409   FB_
 410   TICK_RET_UNBOXED_TUP(0);
 411   w = (StgDeadWeak *)R1.p;
 412
 413   /* already dead? */
 414   if (w->header.info == &DEAD_WEAK_info) {
 415       RET_NP(0,&NO_FINALIZER_closure);
 416   }
 417
 418   /* kill it */
 419   w->header.info = &DEAD_WEAK_info;
 420   f = ((StgWeak *)w)->finalizer;
 421   w->link = ((StgWeak *)w)->link;
 422
 423   /* return the finalizer */
 424   if (f == &NO_FINALIZER_closure) {
 425       RET_NP(0,&NO_FINALIZER_closure);
 426   } else {
 427       RET_NP(1,f);
 428   }
 429   FE_
 430 }
 431
 432 #endif /* !PAR */
 433
 434 /* -----------------------------------------------------------------------------
 435    Arbitrary-precision Integer operations.
 436    -------------------------------------------------------------------------- */
 437
 438 FN_(int2Integerzh_fast)
 439 {
 440    /* arguments: R1 = Int# */
 441
 442    I_ val, s;           /* to avoid aliasing */
 443    StgArrWords* p;      /* address of array result */
 444    FB_
 445
 446    val = R1.i;
 447    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 448    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 449    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 450
 451    p = (StgArrWords *)Hp - 1;
 452    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 453
 454    /* mpz_set_si is inlined here, makes things simpler */
 455    if (val < 0) {
 456         s  = -1;
 457         *Hp = -val;
 458    } else if (val > 0) {
 459         s = 1;
 460         *Hp = val;
 461    } else {
 462         s = 0;
 463    }
 464
 465    /* returns (# size  :: Int#,
 466                  data  :: ByteArray#
 467                #)
 468    */
 469    TICK_RET_UNBOXED_TUP(2);
 470    RET_NP(s,p);
 471    FE_
 472 }
 473
 474 FN_(word2Integerzh_fast)
 475 {
 476    /* arguments: R1 = Word# */
 477
 478    W_ val;              /* to avoid aliasing */
 479    I_  s;
 480    StgArrWords* p;      /* address of array result */
 481    FB_
 482
 483    val = R1.w;
 484    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 485    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 486    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 487
 488    p = (StgArrWords *)Hp - 1;
 489    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 490
 491    if (val != 0) {
 492         s = 1;
 493         *Hp = val;
 494    } else {
 495         s = 0;
 496    }
 497
 498    /* returns (# size  :: Int#,
 499                  data  :: ByteArray#
 500                #)
 501    */
 502    TICK_RET_UNBOXED_TUP(2);
 503    RET_NP(s,p);
 504    FE_
 505 }
 506
 507
 508 /*
 509  * 'long long' primops for converting to/from Integers.
 510  */
 511
 512 #ifdef SUPPORT_LONG_LONGS
 513
 514 FN_(int64ToIntegerzh_fast)
 515 {
 516    /* arguments: L1 = Int64# */
 517
 518    StgInt64  val; /* to avoid aliasing */
 519    W_ hi;
 520    I_  s, neg, words_needed;
 521    StgArrWords* p;      /* address of array result */
 522    FB_
 523
 524    val = (LI_)L1;
 525    neg = 0;
 526
 527    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 528        words_needed = 2;
 529    } else {
 530        /* minimum is one word */
 531        words_needed = 1;
 532    }
 533    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 534    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 535    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 536
 537    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 538    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 539
 540    if ( val < 0LL ) {
 541      neg = 1;
 542      val = -val;
 543    }
 544
 545    hi = (W_)((LW_)val / 0x100000000ULL);
 546
 547    if ( words_needed == 2 )  {
 548       s = 2;
 549       Hp[-1] = (W_)val;
 550       Hp[0] = hi;
 551    } else if ( val != 0 ) {
 552       s = 1;
 553       Hp[0] = (W_)val;
 554    }  else /* val==0 */   {
 555       s = 0;
 556    }
 557    s = ( neg ? -s : s );
 558
 559    /* returns (# size  :: Int#,
 560                  data  :: ByteArray#
 561                #)
 562    */
 563    TICK_RET_UNBOXED_TUP(2);
 564    RET_NP(s,p);
 565    FE_
 566 }
 567
 568 FN_(word64ToIntegerzh_fast)
 569 {
 570    /* arguments: L1 = Word64# */
 571
 572    StgWord64 val; /* to avoid aliasing */
 573    StgWord hi;
 574    I_  s, words_needed;
 575    StgArrWords* p;      /* address of array result */
 576    FB_
 577
 578    val = (LW_)L1;
 579    if ( val >= 0x100000000ULL ) {
 580       words_needed = 2;
 581    } else {
 582       words_needed = 1;
 583    }
 584    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 585    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 586    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 587
 588    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 589    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 590
 591    hi = (W_)((LW_)val / 0x100000000ULL);
 592    if ( val >= 0x100000000ULL ) {
 593      s = 2;
 594      Hp[-1] = ((W_)val);
 595      Hp[0]  = (hi);
 596    } else if ( val != 0 )      {
 597       s = 1;
 598       Hp[0] = ((W_)val);
 599    } else /* val==0 */         {
 600       s = 0;
 601    }
 602
 603    /* returns (# size  :: Int#,
 604                  data  :: ByteArray#
 605                #)
 606    */
 607    TICK_RET_UNBOXED_TUP(2);
 608    RET_NP(s,p);
 609    FE_
 610 }
 611
 612
 613 #endif /* HAVE_LONG_LONG */
 614
 615 /* ToDo: this is shockingly inefficient */
 616
 617 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 618 FN_(name)                                                               \
 619 {                                                                       \
 620   MP_INT arg1, arg2, result;                                            \
 621   I_ s1, s2;                                                            \
 622   StgArrWords* d1;                                                      \
 623   StgArrWords* d2;                                                      \
 624   FB_                                                                   \
 625                                                                         \
 626   /* call doYouWantToGC() */                                            \
 627   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 628                                                                         \
 629   d1 = (StgArrWords *)R2.p;                                             \
 630   s1 = R1.i;                                                            \
 631   d2 = (StgArrWords *)R4.p;                                             \
 632   s2 = R3.i;                                                            \
 633                                                                         \
 634   arg1._mp_alloc        = d1->words;                                    \
 635   arg1._mp_size         = (s1);                                         \
 636   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 637   arg2._mp_alloc        = d2->words;                                    \
 638   arg2._mp_size         = (s2);                                         \
 639   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 640                                                                         \
 641   STGCALL1(mpz_init,&result);                                           \
 642                                                                         \
 643   /* Perform the operation */                                           \
 644   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 645                                                                         \
 646   TICK_RET_UNBOXED_TUP(2);                                              \
 647   RET_NP(result._mp_size,                                               \
 648          result._mp_d-sizeofW(StgArrWords));                            \
 649   FE_                                                                   \
 650 }
 651
 652 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 653 FN_(name)                                                               \
 654 {                                                                       \
 655   MP_INT arg1, arg2, result1, result2;                                  \
 656   I_ s1, s2;                                                            \
 657   StgArrWords* d1;                                                      \
 658   StgArrWords* d2;                                                      \
 659   FB_                                                                   \
 660                                                                         \
 661   /* call doYouWantToGC() */                                            \
 662   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 663                                                                         \
 664   d1 = (StgArrWords *)R2.p;                                             \
 665   s1 = R1.i;                                                            \
 666   d2 = (StgArrWords *)R4.p;                                             \
 667   s2 = R3.i;                                                            \
 668                                                                         \
 669   arg1._mp_alloc        = d1->words;                                    \
 670   arg1._mp_size         = (s1);                                         \
 671   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 672   arg2._mp_alloc        = d2->words;                                    \
 673   arg2._mp_size         = (s2);                                         \
 674   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 675                                                                         \
 676   STGCALL1(mpz_init,&result1);                                          \
 677   STGCALL1(mpz_init,&result2);                                          \
 678                                                                         \
 679   /* Perform the operation */                                           \
 680   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 681                                                                         \
 682   TICK_RET_UNBOXED_TUP(4);                                              \
 683   RET_NPNP(result1._mp_size,                                            \
 684            result1._mp_d-sizeofW(StgArrWords),                          \
 685            result2._mp_size,                                            \
 686            result2._mp_d-sizeofW(StgArrWords));                         \
 687   FE_                                                                   \
 688 }
 689
 690 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 691 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 692 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 693 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 694 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 695 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 696 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 697
 698 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 699 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 700
 701 #ifndef FLOATS_AS_DOUBLES
 702 FN_(decodeFloatzh_fast)
 703 {
 704   MP_INT mantissa;
 705   I_ exponent;
 706   StgArrWords* p;
 707   StgFloat arg;
 708   FB_
 709
 710   /* arguments: F1 = Float# */
 711   arg = F1;
 712
 713   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 714   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 715   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 716
 717   /* Be prepared to tell Lennart-coded __decodeFloat    */
 718   /* where mantissa._mp_d can be put (it does not care about the rest) */
 719   p = (StgArrWords *)Hp - 1;
 720   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 721   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 722
 723   /* Perform the operation */
 724   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 725
 726   /* returns: (Int# (expn), Int#, ByteArray#) */
 727   TICK_RET_UNBOXED_TUP(3);
 728   RET_NNP(exponent,mantissa._mp_size,p);
 729   FE_
 730 }
 731 #endif /* !FLOATS_AS_DOUBLES */
 732
 733 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 734 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 735
 736 FN_(decodeDoublezh_fast)
 737 { MP_INT mantissa;
 738   I_ exponent;
 739   StgDouble arg;
 740   StgArrWords* p;
 741   FB_
 742
 743   /* arguments: D1 = Double# */
 744   arg = D1;
 745
 746   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 747   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 748   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 749
 750   /* Be prepared to tell Lennart-coded __decodeDouble   */
 751   /* where mantissa.d can be put (it does not care about the rest) */
 752   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 753   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 754   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 755
 756   /* Perform the operation */
 757   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 758
 759   /* returns: (Int# (expn), Int#, ByteArray#) */
 760   TICK_RET_UNBOXED_TUP(3);
 761   RET_NNP(exponent,mantissa._mp_size,p);
 762   FE_
 763 }
 764
 765 /* -----------------------------------------------------------------------------
 766  * Concurrency primitives
 767  * -------------------------------------------------------------------------- */
 768
 769 FN_(forkzh_fast)
 770 {
 771   FB_
 772   /* args: R1 = closure to spark */
 773
 774   MAYBE_GC(R1_PTR, forkzh_fast);
 775
 776   /* create it right now, return ThreadID in R1 */
 777   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 778                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 779   STGCALL1(scheduleThread, R1.t);
 780
 781   /* switch at the earliest opportunity */
 782   context_switch = 1;
 783
 784   JMP_(ENTRY_CODE(Sp[0]));
 785   FE_
 786 }
 787
 788 FN_(yieldzh_fast)
 789 {
 790   FB_
 791   JMP_(stg_yield_noregs);
 792   FE_
 793 }
 794
 795 FN_(newMVarzh_fast)
 796 {
 797   StgMVar *mvar;
 798
 799   FB_
 800   /* args: none */
 801
 802   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 803   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 804                   1, 0);
 805   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 806
 807   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 808   SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
 809   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 810   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 811
 812   TICK_RET_UNBOXED_TUP(1);
 813   RET_P(mvar);
 814   FE_
 815 }
 816
 817 FN_(takeMVarzh_fast)
 818 {
 819   StgMVar *mvar;
 820   StgClosure *val;
 821   const StgInfoTable *info;
 822
 823   FB_
 824   /* args: R1 = MVar closure */
 825
 826   mvar = (StgMVar *)R1.p;
 827
 828 #ifdef SMP
 829   info = LOCK_CLOSURE(mvar);
 830 #else
 831   info = GET_INFO(mvar);
 832 #endif
 833
 834   /* If the MVar is empty, put ourselves on its blocking queue,
 835    * and wait until we're woken up.
 836    */
 837   if (info == &EMPTY_MVAR_info) {
 838     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 839       mvar->head = CurrentTSO;
 840     } else {
 841       mvar->tail->link = CurrentTSO;
 842     }
 843     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 844     CurrentTSO->why_blocked = BlockedOnMVar;
 845     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 846     mvar->tail = CurrentTSO;
 847
 848 #ifdef SMP
 849     /* unlock the MVar */
 850     mvar->header.info = &EMPTY_MVAR_info;
 851 #endif
 852     BLOCK(R1_PTR, takeMVarzh_fast);
 853   }
 854
 855   val = mvar->value;
 856   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 857
 858   /* do this last... we might have locked the MVar in the SMP case,
 859    * and writing the info pointer will unlock it.
 860    */
 861   SET_INFO(mvar,&EMPTY_MVAR_info);
 862
 863   TICK_RET_UNBOXED_TUP(1);
 864   RET_P(val);
 865   FE_
 866 }
 867
 868 FN_(tryTakeMVarzh_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 (info == &EMPTY_MVAR_info) {
 886
 887 #ifdef SMP
 888     /* unlock the MVar */
 889     mvar->header.info = &EMPTY_MVAR_info;
 890 #endif
 891
 892     /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
 893     RET_NP(0, &NO_FINALIZER_closure);
 894   }
 895
 896   val = mvar->value;
 897   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 898
 899   /* do this last... we might have locked the MVar in the SMP case,
 900    * and writing the info pointer will unlock it.
 901    */
 902   SET_INFO(mvar,&EMPTY_MVAR_info);
 903
 904   TICK_RET_UNBOXED_TUP(1);
 905   RET_NP(1,val);
 906   FE_
 907 }
 908
 909 FN_(putMVarzh_fast)
 910 {
 911   StgMVar *mvar;
 912   const StgInfoTable *info;
 913
 914   FB_
 915   /* args: R1 = MVar, R2 = value */
 916
 917   mvar = (StgMVar *)R1.p;
 918
 919 #ifdef SMP
 920   info = LOCK_CLOSURE(mvar);
 921 #else
 922   info = GET_INFO(mvar);
 923 #endif
 924
 925   if (info == &FULL_MVAR_info) {
 926 #ifdef INTERPRETER
 927     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
 928     exit(1);
 929 #else
 930     R1.cl = (StgClosure *)PutFullMVar_closure;
 931     JMP_(raisezh_fast);
 932 #endif
 933   }
 934
 935   mvar->value = R2.cl;
 936
 937   /* wake up the first thread on the queue, it will continue with the
 938    * takeMVar operation and mark the MVar empty again.
 939    */
 940   if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
 941     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 942 #if defined(GRAN)
 943     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 944 #elif defined(PAR)
 945     // ToDo: check 2nd arg (mvar) is right
 946     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 947 #else
 948     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 949 #endif
 950     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 951       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 952     }
 953   }
 954
 955   /* unlocks the MVar in the SMP case */
 956   SET_INFO(mvar,&FULL_MVAR_info);
 957
 958   /* ToDo: yield here for better communication performance? */
 959   JMP_(ENTRY_CODE(Sp[0]));
 960   FE_
 961 }
 962
 963 /* -----------------------------------------------------------------------------
 964    Stable pointer primitives
 965    -------------------------------------------------------------------------  */
 966
 967 FN_(makeStableNamezh_fast)
 968 {
 969   StgWord index;
 970   StgStableName *sn_obj;
 971   FB_
 972
 973   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 974   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 975                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
 976   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
 977
 978   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 979
 980   /* Is there already a StableName for this heap object? */
 981   if (stable_ptr_table[index].sn_obj == NULL) {
 982     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
 983     sn_obj->header.info = &STABLE_NAME_info;
 984     sn_obj->sn = index;
 985     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
 986   } else {
 987     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
 988   }
 989
 990   TICK_RET_UNBOXED_TUP(1);
 991   RET_P(sn_obj);
 992 }
 993
 994 /* -----------------------------------------------------------------------------
 995    Thread I/O blocking primitives
 996    -------------------------------------------------------------------------- */
 997
 998 FN_(waitReadzh_fast)
 999 {
1000   FB_
1001     /* args: R1.i */
1002     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1003     CurrentTSO->why_blocked = BlockedOnRead;
1004     CurrentTSO->block_info.fd = R1.i;
1005     ACQUIRE_LOCK(&sched_mutex);
1006     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1007     RELEASE_LOCK(&sched_mutex);
1008     JMP_(stg_block_noregs);
1009   FE_
1010 }
1011
1012 FN_(waitWritezh_fast)
1013 {
1014   FB_
1015     /* args: R1.i */
1016     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1017     CurrentTSO->why_blocked = BlockedOnWrite;
1018     CurrentTSO->block_info.fd = R1.i;
1019     ACQUIRE_LOCK(&sched_mutex);
1020     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1021     RELEASE_LOCK(&sched_mutex);
1022     JMP_(stg_block_noregs);
1023   FE_
1024 }
1025
1026 FN_(delayzh_fast)
1027 {
1028   StgTSO *t, *prev;
1029   nat target;
1030   FB_
1031     /* args: R1.i */
1032     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1033     CurrentTSO->why_blocked = BlockedOnDelay;
1034
1035     ACQUIRE_LOCK(&sched_mutex);
1036
1037     target = (R1.i / (TICK_MILLISECS*1000)) + timestamp + ticks_since_timestamp;
1038     CurrentTSO->block_info.target = target;
1039
1040     /* Insert the new thread in the sleeping queue. */
1041     prev = NULL;
1042     t = sleeping_queue;
1043     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1044         prev = t;
1045         t = t->link;
1046     }
1047
1048     CurrentTSO->link = t;
1049     if (prev == NULL) {
1050         sleeping_queue = CurrentTSO;
1051     } else {
1052         prev->link = CurrentTSO;
1053     }
1054
1055     RELEASE_LOCK(&sched_mutex);
1056     JMP_(stg_block_noregs);
1057   FE_
1058 }
1059