ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.62 2000/12/11 12:59:25 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, &stg_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,&stg_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,&stg_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,&stg_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,&stg_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 = &stg_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, &stg_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 == &stg_DEAD_WEAK_info) {
 415       RET_NP(0,&stg_NO_FINALIZER_closure);
 416   }
 417
 418   /* kill it */
 419   w->header.info = &stg_DEAD_WEAK_info;
 420   f = ((StgWeak *)w)->finalizer;
 421   w->link = ((StgWeak *)w)->link;
 422
 423   /* return the finalizer */
 424   if (f == &stg_NO_FINALIZER_closure) {
 425       RET_NP(0,&stg_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, &stg_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, &stg_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, &stg_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, &stg_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 FN_(decodeFloatzh_fast)
 735 {
 736   MP_INT mantissa;
 737   I_ exponent;
 738   StgArrWords* p;
 739   StgFloat arg;
 740   FB_
 741
 742   /* arguments: F1 = Float# */
 743   arg = F1;
 744
 745   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 746   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 747   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 748
 749   /* Be prepared to tell Lennart-coded __decodeFloat    */
 750   /* where mantissa._mp_d can be put (it does not care about the rest) */
 751   p = (StgArrWords *)Hp - 1;
 752   SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
 753   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 754
 755   /* Perform the operation */
 756   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 757
 758   /* returns: (Int# (expn), Int#, ByteArray#) */
 759   TICK_RET_UNBOXED_TUP(3);
 760   RET_NNP(exponent,mantissa._mp_size,p);
 761   FE_
 762 }
 763
 764 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 765 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 766
 767 FN_(decodeDoublezh_fast)
 768 { MP_INT mantissa;
 769   I_ exponent;
 770   StgDouble arg;
 771   StgArrWords* p;
 772   FB_
 773
 774   /* arguments: D1 = Double# */
 775   arg = D1;
 776
 777   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 778   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 779   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 780
 781   /* Be prepared to tell Lennart-coded __decodeDouble   */
 782   /* where mantissa.d can be put (it does not care about the rest) */
 783   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 784   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 785   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 786
 787   /* Perform the operation */
 788   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 789
 790   /* returns: (Int# (expn), Int#, ByteArray#) */
 791   TICK_RET_UNBOXED_TUP(3);
 792   RET_NNP(exponent,mantissa._mp_size,p);
 793   FE_
 794 }
 795
 796 /* -----------------------------------------------------------------------------
 797  * Concurrency primitives
 798  * -------------------------------------------------------------------------- */
 799
 800 FN_(forkzh_fast)
 801 {
 802   FB_
 803   /* args: R1 = closure to spark */
 804
 805   MAYBE_GC(R1_PTR, forkzh_fast);
 806
 807   /* create it right now, return ThreadID in R1 */
 808   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 809                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 810   STGCALL1(scheduleThread, R1.t);
 811
 812   /* switch at the earliest opportunity */
 813   context_switch = 1;
 814
 815   JMP_(ENTRY_CODE(Sp[0]));
 816   FE_
 817 }
 818
 819 FN_(yieldzh_fast)
 820 {
 821   FB_
 822   JMP_(stg_yield_noregs);
 823   FE_
 824 }
 825
 826 FN_(newMVarzh_fast)
 827 {
 828   StgMVar *mvar;
 829
 830   FB_
 831   /* args: none */
 832
 833   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 834   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 835                   1, 0);
 836   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 837
 838   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 839   SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
 840   mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 841   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 842
 843   TICK_RET_UNBOXED_TUP(1);
 844   RET_P(mvar);
 845   FE_
 846 }
 847
 848 FN_(takeMVarzh_fast)
 849 {
 850   StgMVar *mvar;
 851   StgClosure *val;
 852   const StgInfoTable *info;
 853
 854   FB_
 855   /* args: R1 = MVar closure */
 856
 857   mvar = (StgMVar *)R1.p;
 858
 859 #ifdef SMP
 860   info = LOCK_CLOSURE(mvar);
 861 #else
 862   info = GET_INFO(mvar);
 863 #endif
 864
 865   /* If the MVar is empty, put ourselves on its blocking queue,
 866    * and wait until we're woken up.
 867    */
 868   if (info == &stg_EMPTY_MVAR_info) {
 869     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 870       mvar->head = CurrentTSO;
 871     } else {
 872       mvar->tail->link = CurrentTSO;
 873     }
 874     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 875     CurrentTSO->why_blocked = BlockedOnMVar;
 876     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 877     mvar->tail = CurrentTSO;
 878
 879 #ifdef SMP
 880     /* unlock the MVar */
 881     mvar->header.info = &stg_EMPTY_MVAR_info;
 882 #endif
 883     BLOCK(R1_PTR, takeMVarzh_fast);
 884   }
 885
 886   val = mvar->value;
 887   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 888
 889   /* do this last... we might have locked the MVar in the SMP case,
 890    * and writing the info pointer will unlock it.
 891    */
 892   SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 893
 894   TICK_RET_UNBOXED_TUP(1);
 895   RET_P(val);
 896   FE_
 897 }
 898
 899 FN_(tryTakeMVarzh_fast)
 900 {
 901   StgMVar *mvar;
 902   StgClosure *val;
 903   const StgInfoTable *info;
 904
 905   FB_
 906   /* args: R1 = MVar closure */
 907
 908   mvar = (StgMVar *)R1.p;
 909
 910 #ifdef SMP
 911   info = LOCK_CLOSURE(mvar);
 912 #else
 913   info = GET_INFO(mvar);
 914 #endif
 915
 916   if (info == &stg_EMPTY_MVAR_info) {
 917
 918 #ifdef SMP
 919     /* unlock the MVar */
 920     mvar->header.info = &stg_EMPTY_MVAR_info;
 921 #endif
 922
 923     /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
 924     RET_NP(0, &stg_NO_FINALIZER_closure);
 925   }
 926
 927   val = mvar->value;
 928   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
 929
 930   /* do this last... we might have locked the MVar in the SMP case,
 931    * and writing the info pointer will unlock it.
 932    */
 933   SET_INFO(mvar,&stg_EMPTY_MVAR_info);
 934
 935   TICK_RET_UNBOXED_TUP(1);
 936   RET_NP(1,val);
 937   FE_
 938 }
 939
 940 FN_(putMVarzh_fast)
 941 {
 942   StgMVar *mvar;
 943   const StgInfoTable *info;
 944
 945   FB_
 946   /* args: R1 = MVar, R2 = value */
 947
 948   mvar = (StgMVar *)R1.p;
 949
 950 #ifdef SMP
 951   info = LOCK_CLOSURE(mvar);
 952 #else
 953   info = GET_INFO(mvar);
 954 #endif
 955
 956   if (info == &stg_FULL_MVAR_info) {
 957 #ifdef INTERPRETER
 958     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
 959     exit(1);
 960 #else
 961     R1.cl = (StgClosure *)PutFullMVar_closure;
 962     JMP_(raisezh_fast);
 963 #endif
 964   }
 965
 966   mvar->value = R2.cl;
 967
 968   /* wake up the first thread on the queue, it will continue with the
 969    * takeMVar operation and mark the MVar empty again.
 970    */
 971   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 972     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 973 #if defined(GRAN)
 974     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 975 #elif defined(PAR)
 976     // ToDo: check 2nd arg (mvar) is right
 977     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 978 #else
 979     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 980 #endif
 981     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
 982       mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
 983     }
 984   }
 985
 986   /* unlocks the MVar in the SMP case */
 987   SET_INFO(mvar,&stg_FULL_MVAR_info);
 988
 989   /* ToDo: yield here for better communication performance? */
 990   JMP_(ENTRY_CODE(Sp[0]));
 991   FE_
 992 }
 993
 994 /* -----------------------------------------------------------------------------
 995    Stable pointer primitives
 996    -------------------------------------------------------------------------  */
 997
 998 FN_(makeStableNamezh_fast)
 999 {
1000   StgWord index;
1001   StgStableName *sn_obj;
1002   FB_
1003
1004   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1005   TICK_ALLOC_PRIM(sizeofW(StgHeader),
1006                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1007   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1008
1009   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1010
1011   /* Is there already a StableName for this heap object? */
1012   if (stable_ptr_table[index].sn_obj == NULL) {
1013     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1014     sn_obj->header.info = &stg_STABLE_NAME_info;
1015     sn_obj->sn = index;
1016     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1017   } else {
1018     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1019   }
1020
1021   TICK_RET_UNBOXED_TUP(1);
1022   RET_P(sn_obj);
1023 }
1024
1025 /* -----------------------------------------------------------------------------
1026    Bytecode object primitives
1027    -------------------------------------------------------------------------  */
1028
1029 FN_(newBCOzh_fast)
1030 {
1031   /* R1.p = instrs
1032      R2.p = literals
1033      R3.p = ptrs
1034   */
1035   StgBCO *bco;
1036   FB_
1037
1038   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR, newBCOzh_fast,);
1039   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1040   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1041
1042   bco = (StgBCO *) (Hp + 1 - sizeof(StgBCO));
1043   SET_HDR(bco, &stg_BCO_info, CCCS);
1044
1045   bco->instrs     = R1.cl;
1046   bco->literals   = R2.cl;
1047   bco->ptrs       = R3.cl;
1048
1049   TICK_RET_UNBOXED_TUP(1);
1050   RET_P(bco);
1051   FE_
1052 }
1053
1054 /* -----------------------------------------------------------------------------
1055    Thread I/O blocking primitives
1056    -------------------------------------------------------------------------- */
1057
1058 FN_(waitReadzh_fast)
1059 {
1060   FB_
1061     /* args: R1.i */
1062     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1063     CurrentTSO->why_blocked = BlockedOnRead;
1064     CurrentTSO->block_info.fd = R1.i;
1065     ACQUIRE_LOCK(&sched_mutex);
1066     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1067     RELEASE_LOCK(&sched_mutex);
1068     JMP_(stg_block_noregs);
1069   FE_
1070 }
1071
1072 FN_(waitWritezh_fast)
1073 {
1074   FB_
1075     /* args: R1.i */
1076     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1077     CurrentTSO->why_blocked = BlockedOnWrite;
1078     CurrentTSO->block_info.fd = R1.i;
1079     ACQUIRE_LOCK(&sched_mutex);
1080     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1081     RELEASE_LOCK(&sched_mutex);
1082     JMP_(stg_block_noregs);
1083   FE_
1084 }
1085
1086 FN_(delayzh_fast)
1087 {
1088   StgTSO *t, *prev;
1089   nat target;
1090   FB_
1091     /* args: R1.i */
1092     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1093     CurrentTSO->why_blocked = BlockedOnDelay;
1094
1095     ACQUIRE_LOCK(&sched_mutex);
1096
1097     target = (R1.i / (TICK_MILLISECS*1000)) + timestamp + ticks_since_timestamp;
1098     CurrentTSO->block_info.target = target;
1099
1100     /* Insert the new thread in the sleeping queue. */
1101     prev = NULL;
1102     t = sleeping_queue;
1103     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1104         prev = t;
1105         t = t->link;
1106     }
1107
1108     CurrentTSO->link = t;
1109     if (prev == NULL) {
1110         sleeping_queue = CurrentTSO;
1111     } else {
1112         prev->link = CurrentTSO;
1113     }
1114
1115     RELEASE_LOCK(&sched_mutex);
1116     JMP_(stg_block_noregs);
1117   FE_
1118 }
1119