ghc/rts/PrimOps.hc

   1 /* -----------------------------------------------------------------------------
   2  * $Id: PrimOps.hc,v 1.46 2000/03/14 09:55:05 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 "Prelude.h"
  23
  24 /* ** temporary **
  25
  26    classes CCallable and CReturnable don't really exist, but the
  27    compiler insists on generating dictionaries containing references
  28    to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
  29    for these.
  30 */
  31
  32 W_ GHC_ZCCCallable_static_info[0];
  33 W_ GHC_ZCCReturnable_static_info[0];
  34
  35
  36 /* -----------------------------------------------------------------------------
  37    Macros for Hand-written primitives.
  38    -------------------------------------------------------------------------- */
  39
  40 /*
  41  * Horrible macros for returning unboxed tuples.
  42  *
  43  * How an unboxed tuple is returned depends on two factors:
  44  *    - the number of real registers we have available
  45  *    - the boxedness of the returned fields.
  46  *
  47  * To return an unboxed tuple from a primitive operation, we have macros
  48  * RET_<layout> where <layout> describes the boxedness of each field of the
  49  * unboxed tuple:  N indicates a non-pointer field, and P indicates a pointer.
  50  *
  51  * We only define the cases actually used, to avoid having too much
  52  * garbage in this section.  Warning: any bugs in here will be hard to
  53  * track down.
  54  */
  55
  56 /*------ All Regs available */
  57 #if defined(REG_R8)
  58 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  59 # define RET_N(a)     RET_P(a)
  60
  61 # define RET_PP(a,b)  R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
  62 # define RET_NN(a,b)  RET_PP(a,b)
  63 # define RET_NP(a,b)  RET_PP(a,b)
  64
  65 # define RET_PPP(a,b,c) \
  66         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
  67 # define RET_NNP(a,b,c) RET_PPP(a,b,c)
  68
  69 # define RET_NNNP(a,b,c,d) \
  70         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
  71         JMP_(ENTRY_CODE(Sp[0]));
  72
  73 # define RET_NPNP(a,b,c,d) \
  74         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
  75         JMP_(ENTRY_CODE(Sp[0]));
  76
  77 # define RET_NNPNNP(a,b,c,d,e,f) \
  78         R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
  79         R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
  80         JMP_(ENTRY_CODE(Sp[0]));
  81
  82 #elif defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
  83       defined(REG_R4) || defined(REG_R3)
  84 # error RET_n macros not defined for this setup.
  85
  86 /*------ 2 Registers available */
  87 #elif defined(REG_R2)
  88
  89 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
  90 # define RET_N(a)     RET_P(a)
  91
  92 # define RET_PP(a,b)   R1.w = (W_)(a); R2.w = (W_)(b); \
  93                        JMP_(ENTRY_CODE(Sp[0]));
  94 # define RET_NN(a,b)   RET_PP(a,b)
  95 # define RET_NP(a,b)   RET_PP(a,b)
  96
  97 # define RET_PPP(a,b,c) \
  98         R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
  99         JMP_(ENTRY_CODE(Sp[1]));
 100 # define RET_NNP(a,b,c) \
 101         R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \
 102         JMP_(ENTRY_CODE(Sp[1]));
 103
 104 # define RET_NNNP(a,b,c,d)                      \
 105         R1.w = (W_)(a);                         \
 106         R2.w = (W_)(b);                         \
 107     /*  Sp[-3] = ARGTAG(1); */                  \
 108         Sp[-2] = (W_)(c);                       \
 109         Sp[-1] = (W_)(d);                       \
 110         Sp -= 3;                                \
 111         JMP_(ENTRY_CODE(Sp[3]));
 112
 113 # define RET_NPNP(a,b,c,d)                      \
 114         R1.w = (W_)(a);                         \
 115         R2.w = (W_)(b);                         \
 116     /*  Sp[-3] = ARGTAG(1); */                  \
 117         Sp[-2] = (W_)(c);                       \
 118         Sp[-1] = (W_)(d);                       \
 119         Sp -= 3;                                \
 120         JMP_(ENTRY_CODE(Sp[3]));
 121
 122 # define RET_NNPNNP(a,b,c,d,e,f)                \
 123         R1.w = (W_)(a);                         \
 124         R2.w = (W_)(b);                         \
 125         Sp[-6] = (W_)(c);                       \
 126         /* Sp[-5] = ARGTAG(1); */               \
 127         Sp[-4] = (W_)(d);                       \
 128         /* Sp[-3] = ARGTAG(1); */               \
 129         Sp[-2] = (W_)(e);                       \
 130         Sp[-1] = (W_)(f);                       \
 131         Sp -= 6;                                \
 132         JMP_(ENTRY_CODE(Sp[6]));
 133
 134 /*------ 1 Register available */
 135 #elif defined(REG_R1)
 136 # define RET_P(a)     R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
 137 # define RET_N(a)     RET_P(a)
 138
 139 # define RET_PP(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
 140                        JMP_(ENTRY_CODE(Sp[1]));
 141 # define RET_NN(a,b)   R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
 142                        JMP_(ENTRY_CODE(Sp[2]));
 143 # define RET_NP(a,b)   RET_PP(a,b)
 144
 145 # define RET_PPP(a,b,c) \
 146         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
 147         JMP_(ENTRY_CODE(Sp[2]));
 148 # define RET_NNP(a,b,c) \
 149         R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
 150         JMP_(ENTRY_CODE(Sp[3]));
 151
 152 # define RET_NNNP(a,b,c,d)                      \
 153         R1.w = (W_)(a);                         \
 154     /*  Sp[-5] = ARGTAG(1); */                  \
 155         Sp[-4] = (W_)(b);                       \
 156     /*  Sp[-3] = ARGTAG(1); */                  \
 157         Sp[-2] = (W_)(c);                       \
 158         Sp[-1] = (W_)(d);                       \
 159         Sp -= 5;                                \
 160         JMP_(ENTRY_CODE(Sp[5]));
 161
 162 # define RET_NPNP(a,b,c,d)                      \
 163         R1.w = (W_)(a);                         \
 164         Sp[-4] = (W_)(b);                       \
 165     /*  Sp[-3] = ARGTAG(1); */                  \
 166         Sp[-2] = (W_)(c);                       \
 167         Sp[-1] = (W_)(d);                       \
 168         Sp -= 4;                                \
 169         JMP_(ENTRY_CODE(Sp[4]));
 170
 171 # define RET_NNPNNP(a,b,c,d,e,f)                \
 172         R1.w = (W_)(a);                         \
 173         Sp[-1] = (W_)(f);                       \
 174         Sp[-2] = (W_)(e);                       \
 175         /* Sp[-3] = ARGTAG(1); */               \
 176         Sp[-4] = (W_)(d);                       \
 177         /* Sp[-5] = ARGTAG(1); */               \
 178         Sp[-6] = (W_)(c);                       \
 179         Sp[-7] = (W_)(b);                       \
 180         /* Sp[-8] = ARGTAG(1); */               \
 181         Sp -= 8;                                \
 182         JMP_(ENTRY_CODE(Sp[8]));
 183
 184 #else /* 0 Regs available */
 185
 186 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
 187
 188 #ifdef DEBUG
 189 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);  Sp[-o] = ARG_TAG(1);
 190 #else
 191 #define PUSH_N(o,x) Sp[1-o] = (W_)(x);
 192 #endif
 193
 194 #define PUSHED(m)   Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
 195
 196 /* Here's how to construct these macros:
 197  *
 198  *   N = number of N's in the name;
 199  *   P = number of P's in the name;
 200  *   s = N * 2 + P;
 201  *   while (nonNull(name)) {
 202  *     if (nextChar == 'P') {
 203  *       PUSH_P(s,_);
 204  *       s -= 1;
 205  *     } else {
 206  *       PUSH_N(s,_);
 207  *       s -= 2
 208  *     }
 209  *   }
 210  *   PUSHED(N * 2 + P);
 211  */
 212
 213 # define RET_P(a)     PUSH_P(1,a); PUSHED(1)
 214 # define RET_N(a)     PUSH_N(2,a); PUSHED(2)
 215
 216 # define RET_PP(a,b)   PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
 217 # define RET_NN(a,b)   PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
 218 # define RET_NP(a,b)   PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
 219
 220 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
 221 # define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
 222
 223 # 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)
 224 # 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)
 225 # 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)
 226
 227 #endif
 228
 229 /*-----------------------------------------------------------------------------
 230   Array Primitives
 231
 232   Basically just new*Array - the others are all inline macros.
 233
 234   The size arg is always passed in R1, and the result returned in R1.
 235
 236   The slow entry point is for returning from a heap check, the saved
 237   size argument must be re-loaded from the stack.
 238   -------------------------------------------------------------------------- */
 239
 240 /* for objects that are *less* than the size of a word, make sure we
 241  * round up to the nearest word for the size of the array.
 242  */
 243
 244 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
 245
 246 #define newByteArray(ty,scale)                          \
 247  FN_(new##ty##Arrayzh_fast)                             \
 248  {                                                      \
 249    W_ stuff_size, size, n;                              \
 250    StgArrWords* p;                                      \
 251    FB_                                                  \
 252      MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast);           \
 253      n = R1.w;                                          \
 254      stuff_size = BYTES_TO_STGWORDS(n*scale);           \
 255      size = sizeofW(StgArrWords)+ stuff_size;           \
 256      p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
 257      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
 258      SET_HDR(p, &ARR_WORDS_info, CCCS);         \
 259      p->words = stuff_size;                             \
 260      TICK_RET_UNBOXED_TUP(1)                            \
 261      RET_P(p);                                          \
 262    FE_                                                  \
 263  }
 264
 265 newByteArray(Char,   sizeof(C_))
 266 newByteArray(Int,    sizeof(I_));
 267 newByteArray(Word,   sizeof(W_));
 268 newByteArray(Addr,   sizeof(P_));
 269 newByteArray(Float,  sizeof(StgFloat));
 270 newByteArray(Double, sizeof(StgDouble));
 271 newByteArray(StablePtr, sizeof(StgStablePtr));
 272
 273 FN_(newArrayzh_fast)
 274 {
 275   W_ size, n, init;
 276   StgMutArrPtrs* arr;
 277   StgPtr p;
 278   FB_
 279     n = R1.w;
 280
 281     MAYBE_GC(R2_PTR,newArrayzh_fast);
 282
 283     size = sizeofW(StgMutArrPtrs) + n;
 284     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
 285     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
 286
 287     SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
 288     arr->ptrs = n;
 289
 290     init = R2.w;
 291     for (p = (P_)arr + sizeofW(StgMutArrPtrs);
 292          p < (P_)arr + size; p++) {
 293         *p = (W_)init;
 294     }
 295
 296     TICK_RET_UNBOXED_TUP(1);
 297     RET_P(arr);
 298   FE_
 299 }
 300
 301 FN_(newMutVarzh_fast)
 302 {
 303   StgMutVar* mv;
 304   /* Args: R1.p = initialisation value */
 305   FB_
 306
 307   HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
 308   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
 309   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
 310
 311   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
 312   SET_HDR(mv,&MUT_VAR_info,CCCS);
 313   mv->var = R1.cl;
 314
 315   TICK_RET_UNBOXED_TUP(1);
 316   RET_P(mv);
 317   FE_
 318 }
 319
 320 /* -----------------------------------------------------------------------------
 321    Foreign Object Primitives
 322
 323    -------------------------------------------------------------------------- */
 324
 325 #ifndef PAR
 326 FN_(makeForeignObjzh_fast)
 327 {
 328   /* R1.p = ptr to foreign object,
 329   */
 330   StgForeignObj *result;
 331   FB_
 332
 333   HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
 334   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 335                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
 336   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
 337
 338   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
 339   SET_HDR(result,&FOREIGN_info,CCCS);
 340   result->data = R1.p;
 341
 342   /* returns (# s#, ForeignObj# #) */
 343   TICK_RET_UNBOXED_TUP(1);
 344   RET_P(result);
 345   FE_
 346 }
 347 #endif
 348
 349 /* These two are out-of-line for the benefit of the NCG */
 350 FN_(unsafeThawArrayzh_fast)
 351 {
 352   FB_
 353   SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
 354   recordMutable((StgMutClosure*)R1.cl);
 355
 356   TICK_RET_UNBOXED_TUP(1);
 357   RET_P(R1.p);
 358   FE_
 359 }
 360
 361 /* -----------------------------------------------------------------------------
 362    Weak Pointer Primitives
 363    -------------------------------------------------------------------------- */
 364
 365 #ifndef PAR
 366
 367 FN_(mkWeakzh_fast)
 368 {
 369   /* R1.p = key
 370      R2.p = value
 371      R3.p = finalizer (or NULL)
 372   */
 373   StgWeak *w;
 374   FB_
 375
 376   if (R3.cl == NULL) {
 377     R3.cl = &NO_FINALIZER_closure;
 378   }
 379
 380   HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
 381   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
 382                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
 383   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
 384
 385   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
 386   SET_HDR(w, &WEAK_info, CCCS);
 387
 388   w->key        = R1.cl;
 389   w->value      = R2.cl;
 390   w->finalizer  = R3.cl;
 391
 392   w->link       = weak_ptr_list;
 393   weak_ptr_list = w;
 394   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
 395
 396   TICK_RET_UNBOXED_TUP(1);
 397   RET_P(w);
 398   FE_
 399 }
 400
 401 FN_(finalizzeWeakzh_fast)
 402 {
 403   /* R1.p = weak ptr
 404    */
 405   StgDeadWeak *w;
 406   StgClosure *f;
 407   FB_
 408   TICK_RET_UNBOXED_TUP(0);
 409   w = (StgDeadWeak *)R1.p;
 410
 411   /* already dead? */
 412   if (w->header.info == &DEAD_WEAK_info) {
 413       RET_NP(0,&NO_FINALIZER_closure);
 414   }
 415
 416   /* kill it */
 417   w->header.info = &DEAD_WEAK_info;
 418   f = ((StgWeak *)w)->finalizer;
 419   w->link = ((StgWeak *)w)->link;
 420
 421   /* return the finalizer */
 422   if (f == &NO_FINALIZER_closure) {
 423       RET_NP(0,&NO_FINALIZER_closure);
 424   } else {
 425       RET_NP(1,f);
 426   }
 427   FE_
 428 }
 429
 430 #endif /* !PAR */
 431
 432 /* -----------------------------------------------------------------------------
 433    Arbitrary-precision Integer operations.
 434    -------------------------------------------------------------------------- */
 435
 436 FN_(int2Integerzh_fast)
 437 {
 438    /* arguments: R1 = Int# */
 439
 440    I_ val, s;           /* to avoid aliasing */
 441    StgArrWords* p;      /* address of array result */
 442    FB_
 443
 444    val = R1.i;
 445    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
 446    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 447    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 448
 449    p = (StgArrWords *)Hp - 1;
 450    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 451
 452    /* mpz_set_si is inlined here, makes things simpler */
 453    if (val < 0) {
 454         s  = -1;
 455         *Hp = -val;
 456    } else if (val > 0) {
 457         s = 1;
 458         *Hp = val;
 459    } else {
 460         s = 0;
 461    }
 462
 463    /* returns (# size  :: Int#,
 464                  data  :: ByteArray#
 465                #)
 466    */
 467    TICK_RET_UNBOXED_TUP(2);
 468    RET_NP(s,p);
 469    FE_
 470 }
 471
 472 FN_(word2Integerzh_fast)
 473 {
 474    /* arguments: R1 = Word# */
 475
 476    W_ val;              /* to avoid aliasing */
 477    I_  s;
 478    StgArrWords* p;      /* address of array result */
 479    FB_
 480
 481    val = R1.w;
 482    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
 483    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 484    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 485
 486    p = (StgArrWords *)Hp - 1;
 487    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
 488
 489    if (val != 0) {
 490         s = 1;
 491         *Hp = val;
 492    } else {
 493         s = 0;
 494    }
 495
 496    /* returns (# size  :: Int#,
 497                  data  :: ByteArray#
 498                #)
 499    */
 500    TICK_RET_UNBOXED_TUP(2);
 501    RET_NP(s,p);
 502    FE_
 503 }
 504
 505 FN_(addr2Integerzh_fast)
 506 {
 507   MP_INT result;
 508   char *str;
 509   FB_
 510
 511   MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
 512
 513   /* args:   R1 :: Addr# */
 514   str = R1.a;
 515
 516   /* Perform the operation */
 517   if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
 518       abort();
 519
 520    /* returns (# size  :: Int#,
 521                  data  :: ByteArray#
 522                #)
 523    */
 524   TICK_RET_UNBOXED_TUP(2);
 525   RET_NP(result._mp_size,
 526           result._mp_d - sizeofW(StgArrWords));
 527   FE_
 528 }
 529
 530 /*
 531  * 'long long' primops for converting to/from Integers.
 532  */
 533
 534 #ifdef SUPPORT_LONG_LONGS
 535
 536 FN_(int64ToIntegerzh_fast)
 537 {
 538    /* arguments: L1 = Int64# */
 539
 540    StgInt64  val; /* to avoid aliasing */
 541    W_ hi;
 542    I_  s, neg, words_needed;
 543    StgArrWords* p;      /* address of array result */
 544    FB_
 545
 546    val = (LI_)L1;
 547    neg = 0;
 548
 549    if ( val >= 0x100000000LL || val <= -0x100000000LL )  {
 550        words_needed = 2;
 551    } else {
 552        /* minimum is one word */
 553        words_needed = 1;
 554    }
 555    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
 556    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 557    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 558
 559    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 560    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 561
 562    if ( val < 0LL ) {
 563      neg = 1;
 564      val = -val;
 565    }
 566
 567    hi = (W_)((LW_)val / 0x100000000ULL);
 568
 569    if ( words_needed == 2 )  {
 570       s = 2;
 571       Hp[-1] = (W_)val;
 572       Hp[0] = hi;
 573    } else if ( val != 0 ) {
 574       s = 1;
 575       Hp[0] = (W_)val;
 576    }  else /* val==0 */   {
 577       s = 0;
 578    }
 579    s = ( neg ? -s : s );
 580
 581    /* returns (# size  :: Int#,
 582                  data  :: ByteArray#
 583                #)
 584    */
 585    TICK_RET_UNBOXED_TUP(2);
 586    RET_NP(s,p);
 587    FE_
 588 }
 589
 590 FN_(word64ToIntegerzh_fast)
 591 {
 592    /* arguments: L1 = Word64# */
 593
 594    StgWord64 val; /* to avoid aliasing */
 595    StgWord hi;
 596    I_  s, words_needed;
 597    StgArrWords* p;      /* address of array result */
 598    FB_
 599
 600    val = (LW_)L1;
 601    if ( val >= 0x100000000ULL ) {
 602       words_needed = 2;
 603    } else {
 604       words_needed = 1;
 605    }
 606    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
 607    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
 608    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
 609
 610    p = (StgArrWords *)(Hp-words_needed+1) - 1;
 611    SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
 612
 613    hi = (W_)((LW_)val / 0x100000000ULL);
 614    if ( val >= 0x100000000ULL ) {
 615      s = 2;
 616      Hp[-1] = ((W_)val);
 617      Hp[0]  = (hi);
 618    } else if ( val != 0 )      {
 619       s = 1;
 620       Hp[0] = ((W_)val);
 621    } else /* val==0 */         {
 622       s = 0;
 623    }
 624
 625    /* returns (# size  :: Int#,
 626                  data  :: ByteArray#
 627                #)
 628    */
 629    TICK_RET_UNBOXED_TUP(2);
 630    RET_NP(s,p);
 631    FE_
 632 }
 633
 634
 635 #endif /* HAVE_LONG_LONG */
 636
 637 /* ToDo: this is shockingly inefficient */
 638
 639 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
 640 FN_(name)                                                               \
 641 {                                                                       \
 642   MP_INT arg1, arg2, result;                                            \
 643   I_ s1, s2;                                                            \
 644   StgArrWords* d1;                                                      \
 645   StgArrWords* d2;                                                      \
 646   FB_                                                                   \
 647                                                                         \
 648   /* call doYouWantToGC() */                                            \
 649   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 650                                                                         \
 651   d1 = (StgArrWords *)R2.p;                                             \
 652   s1 = R1.i;                                                            \
 653   d2 = (StgArrWords *)R4.p;                                             \
 654   s2 = R3.i;                                                            \
 655                                                                         \
 656   arg1._mp_alloc        = d1->words;                                    \
 657   arg1._mp_size         = (s1);                                         \
 658   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 659   arg2._mp_alloc        = d2->words;                                    \
 660   arg2._mp_size         = (s2);                                         \
 661   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 662                                                                         \
 663   STGCALL1(mpz_init,&result);                                           \
 664                                                                         \
 665   /* Perform the operation */                                           \
 666   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
 667                                                                         \
 668   TICK_RET_UNBOXED_TUP(2);                                              \
 669   RET_NP(result._mp_size,                                               \
 670          result._mp_d-sizeofW(StgArrWords));                            \
 671   FE_                                                                   \
 672 }
 673
 674 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
 675 FN_(name)                                                               \
 676 {                                                                       \
 677   MP_INT arg1, arg2, result1, result2;                                  \
 678   I_ s1, s2;                                                            \
 679   StgArrWords* d1;                                                      \
 680   StgArrWords* d2;                                                      \
 681   FB_                                                                   \
 682                                                                         \
 683   /* call doYouWantToGC() */                                            \
 684   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
 685                                                                         \
 686   d1 = (StgArrWords *)R2.p;                                             \
 687   s1 = R1.i;                                                            \
 688   d2 = (StgArrWords *)R4.p;                                             \
 689   s2 = R3.i;                                                            \
 690                                                                         \
 691   arg1._mp_alloc        = d1->words;                                    \
 692   arg1._mp_size         = (s1);                                         \
 693   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
 694   arg2._mp_alloc        = d2->words;                                    \
 695   arg2._mp_size         = (s2);                                         \
 696   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
 697                                                                         \
 698   STGCALL1(mpz_init,&result1);                                          \
 699   STGCALL1(mpz_init,&result2);                                          \
 700                                                                         \
 701   /* Perform the operation */                                           \
 702   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
 703                                                                         \
 704   TICK_RET_UNBOXED_TUP(4);                                              \
 705   RET_NPNP(result1._mp_size,                                            \
 706            result1._mp_d-sizeofW(StgArrWords),                          \
 707            result2._mp_size,                                            \
 708            result2._mp_d-sizeofW(StgArrWords));                         \
 709   FE_                                                                   \
 710 }
 711
 712 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
 713 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
 714 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
 715 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
 716 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
 717 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
 718 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
 719
 720 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
 721 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
 722
 723 #ifndef FLOATS_AS_DOUBLES
 724 FN_(decodeFloatzh_fast)
 725 {
 726   MP_INT mantissa;
 727   I_ exponent;
 728   StgArrWords* p;
 729   StgFloat arg;
 730   FB_
 731
 732   /* arguments: F1 = Float# */
 733   arg = F1;
 734
 735   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
 736   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
 737   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
 738
 739   /* Be prepared to tell Lennart-coded __decodeFloat    */
 740   /* where mantissa._mp_d can be put (it does not care about the rest) */
 741   p = (StgArrWords *)Hp - 1;
 742   SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
 743   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 744
 745   /* Perform the operation */
 746   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
 747
 748   /* returns: (Int# (expn), Int#, ByteArray#) */
 749   TICK_RET_UNBOXED_TUP(3);
 750   RET_NNP(exponent,mantissa._mp_size,p);
 751   FE_
 752 }
 753 #endif /* !FLOATS_AS_DOUBLES */
 754
 755 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
 756 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
 757
 758 FN_(decodeDoublezh_fast)
 759 { MP_INT mantissa;
 760   I_ exponent;
 761   StgDouble arg;
 762   StgArrWords* p;
 763   FB_
 764
 765   /* arguments: D1 = Double# */
 766   arg = D1;
 767
 768   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
 769   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
 770   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
 771
 772   /* Be prepared to tell Lennart-coded __decodeDouble   */
 773   /* where mantissa.d can be put (it does not care about the rest) */
 774   p = (StgArrWords *)(Hp-ARR_SIZE+1);
 775   SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
 776   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
 777
 778   /* Perform the operation */
 779   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
 780
 781   /* returns: (Int# (expn), Int#, ByteArray#) */
 782   TICK_RET_UNBOXED_TUP(3);
 783   RET_NNP(exponent,mantissa._mp_size,p);
 784   FE_
 785 }
 786
 787 /* -----------------------------------------------------------------------------
 788  * Concurrency primitives
 789  * -------------------------------------------------------------------------- */
 790
 791 FN_(forkzh_fast)
 792 {
 793   FB_
 794   /* args: R1 = closure to spark */
 795
 796   MAYBE_GC(R1_PTR, forkzh_fast);
 797
 798   /* create it right now, return ThreadID in R1 */
 799   R1.t = RET_STGCALL2(StgTSO *, createIOThread,
 800                       RtsFlags.GcFlags.initialStkSize, R1.cl);
 801   STGCALL1(scheduleThread, R1.t);
 802
 803   /* switch at the earliest opportunity */
 804   context_switch = 1;
 805
 806   JMP_(ENTRY_CODE(Sp[0]));
 807   FE_
 808 }
 809
 810 FN_(yieldzh_fast)
 811 {
 812   FB_
 813   JMP_(stg_yield_noregs);
 814   FE_
 815 }
 816
 817 FN_(newMVarzh_fast)
 818 {
 819   StgMVar *mvar;
 820
 821   FB_
 822   /* args: none */
 823
 824   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
 825   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
 826                   1, 0);
 827   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
 828
 829   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
 830   SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
 831   mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 832   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 833
 834   TICK_RET_UNBOXED_TUP(1);
 835   RET_P(mvar);
 836   FE_
 837 }
 838
 839 FN_(takeMVarzh_fast)
 840 {
 841   StgMVar *mvar;
 842   StgClosure *val;
 843   const StgInfoTable *info;
 844
 845   FB_
 846   /* args: R1 = MVar closure */
 847
 848   mvar = (StgMVar *)R1.p;
 849
 850 #ifdef SMP
 851   info = LOCK_CLOSURE(mvar);
 852 #else
 853   info = GET_INFO(mvar);
 854 #endif
 855
 856   /* If the MVar is empty, put ourselves on its blocking queue,
 857    * and wait until we're woken up.
 858    */
 859   if (info == &EMPTY_MVAR_info) {
 860     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 861       mvar->head = CurrentTSO;
 862     } else {
 863       mvar->tail->link = CurrentTSO;
 864     }
 865     CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
 866     CurrentTSO->why_blocked = BlockedOnMVar;
 867     CurrentTSO->block_info.closure = (StgClosure *)mvar;
 868     mvar->tail = CurrentTSO;
 869
 870 #ifdef SMP
 871     /* unlock the MVar */
 872     mvar->header.info = &EMPTY_MVAR_info;
 873 #endif
 874     BLOCK(R1_PTR, takeMVarzh_fast);
 875   }
 876
 877   val = mvar->value;
 878   mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
 879
 880   /* do this last... we might have locked the MVar in the SMP case,
 881    * and writing the info pointer will unlock it.
 882    */
 883   SET_INFO(mvar,&EMPTY_MVAR_info);
 884
 885   TICK_RET_UNBOXED_TUP(1);
 886   RET_P(val);
 887   FE_
 888 }
 889
 890 FN_(putMVarzh_fast)
 891 {
 892   StgMVar *mvar;
 893   const StgInfoTable *info;
 894
 895   FB_
 896   /* args: R1 = MVar, R2 = value */
 897
 898   mvar = (StgMVar *)R1.p;
 899
 900 #ifdef SMP
 901   info = LOCK_CLOSURE(mvar);
 902 #else
 903   info = GET_INFO(mvar);
 904 #endif
 905
 906   if (info == &FULL_MVAR_info) {
 907 #ifdef INTERPRETER
 908     fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
 909     exit(1);
 910 #else
 911     R1.cl = (StgClosure *)PutFullMVar_closure;
 912     JMP_(raisezh_fast);
 913 #endif
 914   }
 915
 916   mvar->value = R2.cl;
 917
 918   /* wake up the first thread on the queue, it will continue with the
 919    * takeMVar operation and mark the MVar empty again.
 920    */
 921   if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
 922     ASSERT(mvar->head->why_blocked == BlockedOnMVar);
 923 #if defined(GRAN)
 924     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 925 #elif defined(PAR)
 926     // ToDo: check 2nd arg (mvar) is right
 927     mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
 928 #else
 929     mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
 930 #endif
 931     if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
 932       mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
 933     }
 934   }
 935
 936   /* unlocks the MVar in the SMP case */
 937   SET_INFO(mvar,&FULL_MVAR_info);
 938
 939   /* ToDo: yield here for better communication performance? */
 940   JMP_(ENTRY_CODE(Sp[0]));
 941   FE_
 942 }
 943
 944 /* -----------------------------------------------------------------------------
 945    Stable pointer primitives
 946    -------------------------------------------------------------------------  */
 947
 948 FN_(makeStableNamezh_fast)
 949 {
 950   StgWord index;
 951   StgStableName *sn_obj;
 952   FB_
 953
 954   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
 955   TICK_ALLOC_PRIM(sizeofW(StgHeader),
 956                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
 957   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
 958
 959   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
 960
 961   /* Is there already a StableName for this heap object? */
 962   if (stable_ptr_table[index].sn_obj == NULL) {
 963     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
 964     sn_obj->header.info = &STABLE_NAME_info;
 965     sn_obj->sn = index;
 966     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
 967   } else {
 968     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
 969   }
 970
 971   TICK_RET_UNBOXED_TUP(1);
 972   RET_P(sn_obj);
 973 }
 974
 975 /* -----------------------------------------------------------------------------
 976    Thread I/O blocking primitives
 977    -------------------------------------------------------------------------- */
 978
 979 FN_(waitReadzh_fast)
 980 {
 981   FB_
 982     /* args: R1.i */
 983     ASSERT(CurrentTSO->why_blocked == NotBlocked);
 984     CurrentTSO->why_blocked = BlockedOnRead;
 985     CurrentTSO->block_info.fd = R1.i;
 986     ACQUIRE_LOCK(&sched_mutex);
 987     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
 988     RELEASE_LOCK(&sched_mutex);
 989     JMP_(stg_block_noregs);
 990   FE_
 991 }
 992
 993 FN_(waitWritezh_fast)
 994 {
 995   FB_
 996     /* args: R1.i */
 997     ASSERT(CurrentTSO->why_blocked == NotBlocked);
 998     CurrentTSO->why_blocked = BlockedOnWrite;
 999     CurrentTSO->block_info.fd = R1.i;
1000     ACQUIRE_LOCK(&sched_mutex);
1001     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1002     RELEASE_LOCK(&sched_mutex);
1003     JMP_(stg_block_noregs);
1004   FE_
1005 }
1006
1007 FN_(delayzh_fast)
1008 {
1009   FB_
1010     /* args: R1.i */
1011     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1012     CurrentTSO->why_blocked = BlockedOnDelay;
1013
1014     ACQUIRE_LOCK(&sched_mutex);
1015
1016     /* Add on ticks_since_select, since these will be subtracted at
1017      * the next awaitEvent call.
1018      */
1019     CurrentTSO->block_info.delay = R1.i + ticks_since_select;
1020
1021     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1022
1023     RELEASE_LOCK(&sched_mutex);
1024     JMP_(stg_block_noregs);
1025   FE_
1026 }
1027
1028