ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.53 2000/08/07 23:37:23 qrczak 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 FN_(addr2Integerzh_fast)
 508 {
 509   MP_INT result;
 510   char *str;
 511   FB_
 512
 513   MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
 514
 515   /* args:   R1 :: Addr# */
 516   str = R1.a;
 517
 518   /* Perform the operation */
 519   if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
 520       abort();
 521
 522    /* returns (# size  :: Int#,
 523                  data  :: ByteArray#
 524                #)
 525    */
 526   TICK_RET_UNBOXED_TUP(2);
 527   RET_NP(result._mp_size,
 528           result._mp_d - sizeofW(StgArrWords));
 529   FE_
 530 }
 531
 532 /*
 533  * 'long long' primops for converting to/from Integers.
 534  */
 535
 536 #ifdef SUPPORT_LONG_LONGS
 537
 538 FN_(int64ToIntegerzh_fast)
 539 {
 540    /* arguments: L1 = Int64# */
 541
 542    StgInt64  val; /* to avoid aliasing */
 543    W_ hi;
 544    I_  s, neg, words_needed;
 545    StgArrWords* p;      /* address of array result */
 546    FB_
 547
 548    val = (LI_)L1;
 549    neg = 0;
 550
 551    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 552        words_needed = 2;
 553    } else {
 554        /* minimum is one word */
 555        words_needed = 1;
 556    }
 557    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 558    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 559    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 560
 561    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 562    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 563
 564    if ( val < 0LL ) {
 565      neg = 1;
 566      val = -val;
 567    }
 568
 569    hi = (W_)((LW_)val / 0x100000000ULL);
 570
 571    if ( words_needed == 2 )  {
 572       s = 2;
 573       Hp[-1] = (W_)val;
 574       Hp[0] = hi;
 575    } else if ( val != 0 ) {
 576       s = 1;
 577       Hp[0] = (W_)val;
 578    }  else /* val==0 */   {
 579       s = 0;
 580    }
 581    s = ( neg ? -s : s );
 582
 583    /* returns (# size  :: Int#,
 584                  data  :: ByteArray#
 585                #)
 586    */
 587    TICK_RET_UNBOXED_TUP(2);
 588    RET_NP(s,p);
 589    FE_
 590 }
 591
 592 FN_(word64ToIntegerzh_fast)
 593 {
 594    /* arguments: L1 = Word64# */
 595
 596    StgWord64 val; /* to avoid aliasing */
 597    StgWord hi;
 598    I_  s, words_needed;
 599    StgArrWords* p;      /* address of array result */
 600    FB_
 601
 602    val = (LW_)L1;
 603    if ( val >= 0x100000000ULL ) {
 604       words_needed = 2;
 605    } else {
 606       words_needed = 1;
 607    }
 608    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 609    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 610    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 611
 612    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 613    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 614
 615    hi = (W_)((LW_)val / 0x100000000ULL);
 616    if ( val >= 0x100000000ULL ) {
 617      s = 2;
 618      Hp[-1] = ((W_)val);
 619      Hp[0]  = (hi);
 620    } else if ( val != 0 )      {
 621       s = 1;
 622       Hp[0] = ((W_)val);
 623    } else /* val==0 */         {
 624       s = 0;
 625    }
 626
 627    /* returns (# size  :: Int#,
 628                  data  :: ByteArray#
 629                #)
 630    */
 631    TICK_RET_UNBOXED_TUP(2);
 632    RET_NP(s,p);
 633    FE_
 634 }
 635
 636
 637 #endif /* HAVE_LONG_LONG */
 638
 639 /* ToDo: this is shockingly inefficient */
 640
 641 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 642 FN_(name)                                                               \
 643 {                                                                       \
 644   MP_INT arg1, arg2, result;                                            \
 645   I_ s1, s2;                                                            \
 646   StgArrWords* d1;                                                      \
 647   StgArrWords* d2;                                                      \
 648   FB_                                                                   \
 649                                                                         \
 650   /* call doYouWantToGC() */                                            \
 651   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 652                                                                         \
 653   d1 = (StgArrWords *)R2.p;                                             \
 654   s1 = R1.i;                                                            \
 655   d2 = (StgArrWords *)R4.p;                                             \
 656   s2 = R3.i;                                                            \
 657                                                                         \
 658   arg1._mp_alloc        = d1->words;                                    \
 659   arg1._mp_size         = (s1);                                         \
 660   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 661   arg2._mp_alloc        = d2->words;                                    \
 662   arg2._mp_size         = (s2);                                         \
 663   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 664                                                                         \
 665   STGCALL1(mpz_init,&result);                                           \
 666                                                                         \
 667   /* Perform the operation */                                           \
 668   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 669                                                                         \
 670   TICK_RET_UNBOXED_TUP(2);                                              \
 671   RET_NP(result._mp_size,                                               \
 672          result._mp_d-sizeofW(StgArrWords));                            \
 673   FE_                                                                   \
 674 }
 675
 676 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 677 FN_(name)                                                               \
 678 {                                                                       \
 679   MP_INT arg1, arg2, result1, result2;                                  \
 680   I_ s1, s2;                                                            \
 681   StgArrWords* d1;                                                      \
 682   StgArrWords* d2;                                                      \
 683   FB_                                                                   \
 684                                                                         \
 685   /* call doYouWantToGC() */                                            \
 686   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 687                                                                         \
 688   d1 = (StgArrWords *)R2.p;                                             \
 689   s1 = R1.i;                                                            \
 690   d2 = (StgArrWords *)R4.p;                                             \
 691   s2 = R3.i;                                                            \
 692                                                                         \
 693   arg1._mp_alloc        = d1->words;                                    \
 694   arg1._mp_size         = (s1);                                         \
 695   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 696   arg2._mp_alloc        = d2->words;                                    \
 697   arg2._mp_size         = (s2);                                         \
 698   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 699                                                                         \
 700   STGCALL1(mpz_init,&result1);                                          \
 701   STGCALL1(mpz_init,&result2);                                          \
 702                                                                         \
 703   /* Perform the operation */                                           \
 704   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 705                                                                         \
 706   TICK_RET_UNBOXED_TUP(4);                                              \
 707   RET_NPNP(result1._mp_size,                                            \
 708            result1._mp_d-sizeofW(StgArrWords),                          \
 709            result2._mp_size,                                            \
 710            result2._mp_d-sizeofW(StgArrWords));                         \
 711   FE_                                                                   \
 712 }
 713
 714 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 715 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 716 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 717 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 718 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 719 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 720 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 721
 722 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 723 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 724
 725 #ifndef FLOATS_AS_DOUBLES
 726 FN_(decodeFloatzh_fast)
 727 {
 728   MP_INT mantissa;
 729   I_ exponent;
 730   StgArrWords* p;
 731   StgFloat arg;
 732   FB_
 733
 734   /* arguments: F1 = Float# */
 735   arg = F1;
 736
 737   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 738   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 739   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 740
 741   /* Be prepared to tell Lennart-coded __decodeFloat    */
 742   /* where mantissa._mp_d can be put (it does not care about the rest) */
 743   p = (StgArrWords *)Hp - 1;
 744   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 745   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 746
 747   /* Perform the operation */
 748   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 749
 750   /* returns: (Int# (expn), Int#, ByteArray#) */
 751   TICK_RET_UNBOXED_TUP(3);
 752   RET_NNP(exponent,mantissa._mp_size,p);
 753   FE_
 754 }
 755 #endif /* !FLOATS_AS_DOUBLES */
 756
 757 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 758 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 759
 760 FN_(decodeDoublezh_fast)
 761 { MP_INT mantissa;
 762   I_ exponent;
 763   StgDouble arg;
 764   StgArrWords* p;
 765   FB_
 766
 767   /* arguments: D1 = Double# */
 768   arg = D1;
 769
 770   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 771   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 772   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 773
 774   /* Be prepared to tell Lennart-coded __decodeDouble   */
 775   /* where mantissa.d can be put (it does not care about the rest) */
 776   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 777   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 778   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 779
 780   /* Perform the operation */
 781   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 782
 783   /* returns: (Int# (expn), Int#, ByteArray#) */
 784   TICK_RET_UNBOXED_TUP(3);
 785   RET_NNP(exponent,mantissa._mp_size,p);
 786   FE_
 787 }
 788
 789 /* -----------------------------------------------------------------------------
 790  * Concurrency primitives
 791  * -------------------------------------------------------------------------- */
 792
 793 FN_(forkzh_fast)
 794 {
 795   FB_
 796   /* args: R1 = closure to spark */
 797
 798   MAYBE_GC(R1_PTR, forkzh_fast);
 799
 800   /* create it right now, return ThreadID in R1 */
 801   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 802                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 803   STGCALL1(scheduleThread, R1.t);
 804
 805   /* switch at the earliest opportunity */
 806   context_switch = 1;
 807
 808   JMP_(ENTRY_CODE(Sp[0]));
 809   FE_
 810 }
 811
 812 FN_(yieldzh_fast)
 813 {
 814   FB_
 815   JMP_(stg_yield_noregs);
 816   FE_
 817 }
 818
 819 FN_(newMVarzh_fast)
 820 {
 821   StgMVar *mvar;
 822
 823   FB_
 824   /* args: none */
 825
 826   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 827   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 828                   1, 0);
 829   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 830
 831   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 832   SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
 833   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 834   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 835
 836   TICK_RET_UNBOXED_TUP(1);
 837   RET_P(mvar);
 838   FE_
 839 }
 840
 841 FN_(takeMVarzh_fast)
 842 {
 843   StgMVar *mvar;
 844   StgClosure *val;
 845   const StgInfoTable *info;
 846
 847   FB_
 848   /* args: R1 = MVar closure */
 849
 850   mvar = (StgMVar *)R1.p;
 851
 852 #ifdef SMP
 853   info = LOCK_CLOSURE(mvar);
 854 #else
 855   info = GET_INFO(mvar);
 856 #endif
 857
 858   /* If the MVar is empty, put ourselves on its blocking queue,
 859    * and wait until we're woken up.
 860    */
 861   if (info == &EMPTY_MVAR_info) {
 862     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 863       mvar->head = CurrentTSO;
 864     } else {
 865       mvar->tail->link = CurrentTSO;
 866     }
 867     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 868     CurrentTSO->why_blocked = BlockedOnMVar;
 869     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 870     mvar->tail = CurrentTSO;
 871
 872 #ifdef SMP
 873     /* unlock the MVar */
 874     mvar->header.info = &EMPTY_MVAR_info;
 875 #endif
 876     BLOCK(R1_PTR, takeMVarzh_fast);
 877   }
 878
 879   val = mvar->value;
 880   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 881
 882   /* do this last... we might have locked the MVar in the SMP case,
 883    * and writing the info pointer will unlock it.
 884    */
 885   SET_INFO(mvar,&EMPTY_MVAR_info);
 886
 887   TICK_RET_UNBOXED_TUP(1);
 888   RET_P(val);
 889   FE_
 890 }
 891
 892 FN_(tryTakeMVarzh_fast)
 893 {
 894   StgMVar *mvar;
 895   StgClosure *val;
 896   const StgInfoTable *info;
 897
 898   FB_
 899   /* args: R1 = MVar closure */
 900
 901   mvar = (StgMVar *)R1.p;
 902
 903 #ifdef SMP
 904   info = LOCK_CLOSURE(mvar);
 905 #else
 906   info = GET_INFO(mvar);
 907 #endif
 908
 909   if (info == &EMPTY_MVAR_info) {
 910
 911 #ifdef SMP
 912     /* unlock the MVar */
 913     mvar->header.info = &EMPTY_MVAR_info;
 914 #endif
 915
 916     /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
 917     RET_NP(0, &NO_FINALIZER_closure);
 918   }
 919
 920   val = mvar->value;
 921   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 922
 923   /* do this last... we might have locked the MVar in the SMP case,
 924    * and writing the info pointer will unlock it.
 925    */
 926   SET_INFO(mvar,&EMPTY_MVAR_info);
 927
 928   TICK_RET_UNBOXED_TUP(1);
 929   RET_NP(1,val);
 930   FE_
 931 }
 932
 933 FN_(putMVarzh_fast)
 934 {
 935   StgMVar *mvar;
 936   const StgInfoTable *info;
 937
 938   FB_
 939   /* args: R1 = MVar, R2 = value */
 940
 941   mvar = (StgMVar *)R1.p;
 942
 943 #ifdef SMP
 944   info = LOCK_CLOSURE(mvar);
 945 #else
 946   info = GET_INFO(mvar);
 947 #endif
 948
 949   if (info == &FULL_MVAR_info) {
 950 #ifdef INTERPRETER
 951     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
 952     exit(1);
 953 #else
 954     R1.cl = (StgClosure *)PutFullMVar_closure;
 955     JMP_(raisezh_fast);
 956 #endif
 957   }
 958
 959   mvar->value = R2.cl;
 960
 961   /* wake up the first thread on the queue, it will continue with the
 962    * takeMVar operation and mark the MVar empty again.
 963    */
 964   if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
 965     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 966 #if defined(GRAN)
 967     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 968 #elif defined(PAR)
 969     // ToDo: check 2nd arg (mvar) is right
 970     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 971 #else
 972     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 973 #endif
 974     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 975       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 976     }
 977   }
 978
 979   /* unlocks the MVar in the SMP case */
 980   SET_INFO(mvar,&FULL_MVAR_info);
 981
 982   /* ToDo: yield here for better communication performance? */
 983   JMP_(ENTRY_CODE(Sp[0]));
 984   FE_
 985 }
 986
 987 /* -----------------------------------------------------------------------------
 988    Stable pointer primitives
 989    -------------------------------------------------------------------------  */
 990
 991 FN_(makeStableNamezh_fast)
 992 {
 993   StgWord index;
 994   StgStableName *sn_obj;
 995   FB_
 996
 997   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 998   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 999                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1000   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1001
1002   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1003
1004   /* Is there already a StableName for this heap object? */
1005   if (stable_ptr_table[index].sn_obj == NULL) {
1006     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1007     sn_obj->header.info = &STABLE_NAME_info;
1008     sn_obj->sn = index;
1009     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1010   } else {
1011     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1012   }
1013
1014   TICK_RET_UNBOXED_TUP(1);
1015   RET_P(sn_obj);
1016 }
1017
1018 /* -----------------------------------------------------------------------------
1019    Thread I/O blocking primitives
1020    -------------------------------------------------------------------------- */
1021
1022 FN_(waitReadzh_fast)
1023 {
1024   FB_
1025     /* args: R1.i */
1026     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1027     CurrentTSO->why_blocked = BlockedOnRead;
1028     CurrentTSO->block_info.fd = R1.i;
1029     ACQUIRE_LOCK(&sched_mutex);
1030     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1031     RELEASE_LOCK(&sched_mutex);
1032     JMP_(stg_block_noregs);
1033   FE_
1034 }
1035
1036 FN_(waitWritezh_fast)
1037 {
1038   FB_
1039     /* args: R1.i */
1040     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1041     CurrentTSO->why_blocked = BlockedOnWrite;
1042     CurrentTSO->block_info.fd = R1.i;
1043     ACQUIRE_LOCK(&sched_mutex);
1044     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1045     RELEASE_LOCK(&sched_mutex);
1046     JMP_(stg_block_noregs);
1047   FE_
1048 }
1049
1050 FN_(delayzh_fast)
1051 {
1052   FB_
1053     /* args: R1.i */
1054     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1055     CurrentTSO->why_blocked = BlockedOnDelay;
1056
1057     ACQUIRE_LOCK(&sched_mutex);
1058
1059     /* Add on ticks_since_select, since these will be subtracted at
1060      * the next awaitEvent call.
1061      */
1062 #if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS)
1063     CurrentTSO->block_info.delay = R1.i + ticks_since_select;
1064 #else
1065     CurrentTSO->block_info.target = R1.i + getourtimeofday();
1066 #endif
1067
1068     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1069
1070     RELEASE_LOCK(&sched_mutex);
1071     JMP_(stg_block_noregs);
1072   FE_
1073 }
1074
1075