ghc/rts/PrimOps.hc

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