ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.56 2000/11/07 10:42:57 simonmar 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_TAKE1_RET1(name,mp_fun)                                     \
 653 FN_(name)                                                               \
 654 {                                                                       \
 655   MP_INT arg1, result;                                                  \
 656   I_ s1;                                                                \
 657   StgArrWords* d1;                                                      \
 658   FB_                                                                   \
 659                                                                         \
 660   /* call doYouWantToGC() */                                            \
 661   MAYBE_GC(R2_PTR, name);                                               \
 662                                                                         \
 663   d1 = (StgArrWords *)R2.p;                                             \
 664   s1 = R1.i;                                                            \
 665                                                                         \
 666   arg1._mp_alloc        = d1->words;                                    \
 667   arg1._mp_size         = (s1);                                         \
 668   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 669                                                                         \
 670   STGCALL1(mpz_init,&result);                                           \
 671                                                                         \
 672   /* Perform the operation */                                           \
 673   STGCALL2(mp_fun,&result,&arg1);                                       \
 674                                                                         \
 675   TICK_RET_UNBOXED_TUP(2);                                              \
 676   RET_NP(result._mp_size,                                               \
 677          result._mp_d-sizeofW(StgArrWords));                            \
 678   FE_                                                                   \
 679 }
 680
 681 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 682 FN_(name)                                                               \
 683 {                                                                       \
 684   MP_INT arg1, arg2, result1, result2;                                  \
 685   I_ s1, s2;                                                            \
 686   StgArrWords* d1;                                                      \
 687   StgArrWords* d2;                                                      \
 688   FB_                                                                   \
 689                                                                         \
 690   /* call doYouWantToGC() */                                            \
 691   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 692                                                                         \
 693   d1 = (StgArrWords *)R2.p;                                             \
 694   s1 = R1.i;                                                            \
 695   d2 = (StgArrWords *)R4.p;                                             \
 696   s2 = R3.i;                                                            \
 697                                                                         \
 698   arg1._mp_alloc        = d1->words;                                    \
 699   arg1._mp_size         = (s1);                                         \
 700   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 701   arg2._mp_alloc        = d2->words;                                    \
 702   arg2._mp_size         = (s2);                                         \
 703   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 704                                                                         \
 705   STGCALL1(mpz_init,&result1);                                          \
 706   STGCALL1(mpz_init,&result2);                                          \
 707                                                                         \
 708   /* Perform the operation */                                           \
 709   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 710                                                                         \
 711   TICK_RET_UNBOXED_TUP(4);                                              \
 712   RET_NPNP(result1._mp_size,                                            \
 713            result1._mp_d-sizeofW(StgArrWords),                          \
 714            result2._mp_size,                                            \
 715            result2._mp_d-sizeofW(StgArrWords));                         \
 716   FE_                                                                   \
 717 }
 718
 719 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 720 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 721 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 722 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 723 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 724 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 725 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 726 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and);
 727 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior);
 728 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor);
 729 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
 730
 731 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 732 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 733
 734 #ifndef FLOATS_AS_DOUBLES
 735 FN_(decodeFloatzh_fast)
 736 {
 737   MP_INT mantissa;
 738   I_ exponent;
 739   StgArrWords* p;
 740   StgFloat arg;
 741   FB_
 742
 743   /* arguments: F1 = Float# */
 744   arg = F1;
 745
 746   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 747   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 748   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 749
 750   /* Be prepared to tell Lennart-coded __decodeFloat    */
 751   /* where mantissa._mp_d can be put (it does not care about the rest) */
 752   p = (StgArrWords *)Hp - 1;
 753   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 754   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 755
 756   /* Perform the operation */
 757   STGCALL3(__decodeFloat,&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 #endif /* !FLOATS_AS_DOUBLES */
 765
 766 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 767 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 768
 769 FN_(decodeDoublezh_fast)
 770 { MP_INT mantissa;
 771   I_ exponent;
 772   StgDouble arg;
 773   StgArrWords* p;
 774   FB_
 775
 776   /* arguments: D1 = Double# */
 777   arg = D1;
 778
 779   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 780   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 781   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 782
 783   /* Be prepared to tell Lennart-coded __decodeDouble   */
 784   /* where mantissa.d can be put (it does not care about the rest) */
 785   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 786   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 787   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 788
 789   /* Perform the operation */
 790   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 791
 792   /* returns: (Int# (expn), Int#, ByteArray#) */
 793   TICK_RET_UNBOXED_TUP(3);
 794   RET_NNP(exponent,mantissa._mp_size,p);
 795   FE_
 796 }
 797
 798 /* -----------------------------------------------------------------------------
 799  * Concurrency primitives
 800  * -------------------------------------------------------------------------- */
 801
 802 FN_(forkzh_fast)
 803 {
 804   FB_
 805   /* args: R1 = closure to spark */
 806
 807   MAYBE_GC(R1_PTR, forkzh_fast);
 808
 809   /* create it right now, return ThreadID in R1 */
 810   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 811                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 812   STGCALL1(scheduleThread, R1.t);
 813
 814   /* switch at the earliest opportunity */
 815   context_switch = 1;
 816
 817   JMP_(ENTRY_CODE(Sp[0]));
 818   FE_
 819 }
 820
 821 FN_(yieldzh_fast)
 822 {
 823   FB_
 824   JMP_(stg_yield_noregs);
 825   FE_
 826 }
 827
 828 FN_(newMVarzh_fast)
 829 {
 830   StgMVar *mvar;
 831
 832   FB_
 833   /* args: none */
 834
 835   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 836   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 837                   1, 0);
 838   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 839
 840   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 841   SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
 842   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 843   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 844
 845   TICK_RET_UNBOXED_TUP(1);
 846   RET_P(mvar);
 847   FE_
 848 }
 849
 850 FN_(takeMVarzh_fast)
 851 {
 852   StgMVar *mvar;
 853   StgClosure *val;
 854   const StgInfoTable *info;
 855
 856   FB_
 857   /* args: R1 = MVar closure */
 858
 859   mvar = (StgMVar *)R1.p;
 860
 861 #ifdef SMP
 862   info = LOCK_CLOSURE(mvar);
 863 #else
 864   info = GET_INFO(mvar);
 865 #endif
 866
 867   /* If the MVar is empty, put ourselves on its blocking queue,
 868    * and wait until we're woken up.
 869    */
 870   if (info == &EMPTY_MVAR_info) {
 871     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 872       mvar->head = CurrentTSO;
 873     } else {
 874       mvar->tail->link = CurrentTSO;
 875     }
 876     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 877     CurrentTSO->why_blocked = BlockedOnMVar;
 878     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 879     mvar->tail = CurrentTSO;
 880
 881 #ifdef SMP
 882     /* unlock the MVar */
 883     mvar->header.info = &EMPTY_MVAR_info;
 884 #endif
 885     BLOCK(R1_PTR, takeMVarzh_fast);
 886   }
 887
 888   val = mvar->value;
 889   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 890
 891   /* do this last... we might have locked the MVar in the SMP case,
 892    * and writing the info pointer will unlock it.
 893    */
 894   SET_INFO(mvar,&EMPTY_MVAR_info);
 895
 896   TICK_RET_UNBOXED_TUP(1);
 897   RET_P(val);
 898   FE_
 899 }
 900
 901 FN_(tryTakeMVarzh_fast)
 902 {
 903   StgMVar *mvar;
 904   StgClosure *val;
 905   const StgInfoTable *info;
 906
 907   FB_
 908   /* args: R1 = MVar closure */
 909
 910   mvar = (StgMVar *)R1.p;
 911
 912 #ifdef SMP
 913   info = LOCK_CLOSURE(mvar);
 914 #else
 915   info = GET_INFO(mvar);
 916 #endif
 917
 918   if (info == &EMPTY_MVAR_info) {
 919
 920 #ifdef SMP
 921     /* unlock the MVar */
 922     mvar->header.info = &EMPTY_MVAR_info;
 923 #endif
 924
 925     /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
 926     RET_NP(0, &NO_FINALIZER_closure);
 927   }
 928
 929   val = mvar->value;
 930   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 931
 932   /* do this last... we might have locked the MVar in the SMP case,
 933    * and writing the info pointer will unlock it.
 934    */
 935   SET_INFO(mvar,&EMPTY_MVAR_info);
 936
 937   TICK_RET_UNBOXED_TUP(1);
 938   RET_NP(1,val);
 939   FE_
 940 }
 941
 942 FN_(putMVarzh_fast)
 943 {
 944   StgMVar *mvar;
 945   const StgInfoTable *info;
 946
 947   FB_
 948   /* args: R1 = MVar, R2 = value */
 949
 950   mvar = (StgMVar *)R1.p;
 951
 952 #ifdef SMP
 953   info = LOCK_CLOSURE(mvar);
 954 #else
 955   info = GET_INFO(mvar);
 956 #endif
 957
 958   if (info == &FULL_MVAR_info) {
 959 #ifdef INTERPRETER
 960     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
 961     exit(1);
 962 #else
 963     R1.cl = (StgClosure *)PutFullMVar_closure;
 964     JMP_(raisezh_fast);
 965 #endif
 966   }
 967
 968   mvar->value = R2.cl;
 969
 970   /* wake up the first thread on the queue, it will continue with the
 971    * takeMVar operation and mark the MVar empty again.
 972    */
 973   if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
 974     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 975 #if defined(GRAN)
 976     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 977 #elif defined(PAR)
 978     // ToDo: check 2nd arg (mvar) is right
 979     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 980 #else
 981     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 982 #endif
 983     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 984       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 985     }
 986   }
 987
 988   /* unlocks the MVar in the SMP case */
 989   SET_INFO(mvar,&FULL_MVAR_info);
 990
 991   /* ToDo: yield here for better communication performance? */
 992   JMP_(ENTRY_CODE(Sp[0]));
 993   FE_
 994 }
 995
 996 /* -----------------------------------------------------------------------------
 997    Stable pointer primitives
 998    -------------------------------------------------------------------------  */
 999
1000 FN_(makeStableNamezh_fast)
1001 {
1002   StgWord index;
1003   StgStableName *sn_obj;
1004   FB_
1005
1006   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1007   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1008                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1009   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1010
1011   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1012
1013   /* Is there already a StableName for this heap object? */
1014   if (stable_ptr_table[index].sn_obj == NULL) {
1015     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1016     sn_obj->header.info = &STABLE_NAME_info;
1017     sn_obj->sn = index;
1018     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1019   } else {
1020     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1021   }
1022
1023   TICK_RET_UNBOXED_TUP(1);
1024   RET_P(sn_obj);
1025 }
1026
1027 /* -----------------------------------------------------------------------------
1028    Thread I/O blocking primitives
1029    -------------------------------------------------------------------------- */
1030
1031 FN_(waitReadzh_fast)
1032 {
1033   FB_
1034     /* args: R1.i */
1035     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1036     CurrentTSO->why_blocked = BlockedOnRead;
1037     CurrentTSO->block_info.fd = R1.i;
1038     ACQUIRE_LOCK(&sched_mutex);
1039     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1040     RELEASE_LOCK(&sched_mutex);
1041     JMP_(stg_block_noregs);
1042   FE_
1043 }
1044
1045 FN_(waitWritezh_fast)
1046 {
1047   FB_
1048     /* args: R1.i */
1049     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1050     CurrentTSO->why_blocked = BlockedOnWrite;
1051     CurrentTSO->block_info.fd = R1.i;
1052     ACQUIRE_LOCK(&sched_mutex);
1053     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1054     RELEASE_LOCK(&sched_mutex);
1055     JMP_(stg_block_noregs);
1056   FE_
1057 }
1058
1059 FN_(delayzh_fast)
1060 {
1061   StgTSO *t, *prev;
1062   nat target;
1063   FB_
1064     /* args: R1.i */
1065     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1066     CurrentTSO->why_blocked = BlockedOnDelay;
1067
1068     ACQUIRE_LOCK(&sched_mutex);
1069
1070     target = (R1.i / (TICK_MILLISECS*1000)) + timestamp + ticks_since_timestamp;
1071     CurrentTSO->block_info.target = target;
1072
1073     /* Insert the new thread in the sleeping queue. */
1074     prev = NULL;
1075     t = sleeping_queue;
1076     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1077         prev = t;
1078         t = t->link;
1079     }
1080
1081     CurrentTSO->link = t;
1082     if (prev == NULL) {
1083         sleeping_queue = CurrentTSO;
1084     } else {
1085         prev->link = CurrentTSO;
1086     }
1087
1088     RELEASE_LOCK(&sched_mutex);
1089     JMP_(stg_block_noregs);
1090   FE_
1091 }
1092