ghc/rts/PrimOps.hc

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