[project @ 2002-04-10 11:43:43 by stolz]
[ghc-hetmet.git] / ghc / rts / PrimOps.hc
1 /* -----------------------------------------------------------------------------
2  * $Id: PrimOps.hc,v 1.95 2002/04/10 11:43:45 stolz Exp $
3  *
4  * (c) The GHC Team, 1998-2000
5  *
6  * Primitive functions / data
7  *
8  * ---------------------------------------------------------------------------*/
9
10 #include "Stg.h"
11 #include "Rts.h"
12
13 #include "RtsFlags.h"
14 #include "StgStartup.h"
15 #include "SchedAPI.h"
16 #include "Schedule.h"
17 #include "RtsUtils.h"
18 #include "Storage.h"
19 #include "BlockAlloc.h" /* tmp */
20 #include "StablePriv.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.  Some C compilers can't cope with zero-length static arrays,
31    so we have to make these one element long.
32 */
33
34 StgWord GHC_ZCCCallable_static_info[1];
35 StgWord GHC_ZCCReturnable_static_info[1];
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_(newPinnedByteArrayzh_fast)                                  \
266  {                                                              \
267    W_ size, stuff_size, n;                                      \
268    StgArrWords* p;                                              \
269    FB_                                                          \
270      MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast);               \
271      n = R1.w;                                                  \
272      stuff_size = BYTES_TO_STGWORDS(n);                         \
273      size = sizeofW(StgArrWords)+ stuff_size;                   \
274      p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size);   \
275      TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0);        \
276      SET_HDR(p, &stg_ARR_WORDS_info, CCCS);                     \
277      p->words = stuff_size;                                     \
278      TICK_RET_UNBOXED_TUP(1)                                    \
279      RET_P(p);                                                  \
280    FE_                                                          \
281  }
282
283 FN_(newArrayzh_fast)
284 {
285   W_ size, n, init;
286   StgMutArrPtrs* arr;
287   StgPtr p;
288   FB_
289     n = R1.w;
290
291     MAYBE_GC(R2_PTR,newArrayzh_fast);
292
293     size = sizeofW(StgMutArrPtrs) + n;
294     arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
295     TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
296
297     SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
298     arr->ptrs = n;
299
300     init = R2.w;
301     for (p = (P_)arr + sizeofW(StgMutArrPtrs); 
302          p < (P_)arr + size; p++) {
303         *p = (W_)init;
304     }
305
306     TICK_RET_UNBOXED_TUP(1);
307     RET_P(arr);
308   FE_
309 }
310
311 FN_(newMutVarzh_fast)
312 {
313   StgMutVar* mv;
314   /* Args: R1.p = initialisation value */
315   FB_
316
317   HP_CHK_GEN_TICKY(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
318   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
319   CCS_ALLOC(CCCS,sizeofW(StgMutVar));
320
321   mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
322   SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
323   mv->var = R1.cl;
324
325   TICK_RET_UNBOXED_TUP(1);
326   RET_P(mv);
327   FE_
328 }
329
330 /* -----------------------------------------------------------------------------
331    Foreign Object Primitives
332    -------------------------------------------------------------------------- */
333
334 FN_(mkForeignObjzh_fast)
335 {
336   /* R1.p = ptr to foreign object,
337   */
338   StgForeignObj *result;
339   FB_
340
341   HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast,);
342   TICK_ALLOC_PRIM(sizeofW(StgHeader),
343                   sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
344   CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
345
346   result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
347   SET_HDR(result,&stg_FOREIGN_info,CCCS);
348   result->data = R1.p;
349
350   /* returns (# s#, ForeignObj# #) */
351   TICK_RET_UNBOXED_TUP(1);
352   RET_P(result);
353   FE_
354 }
355
356 /* These two are out-of-line for the benefit of the NCG */
357 FN_(unsafeThawArrayzh_fast)
358 {
359   FB_
360   SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
361   recordMutable((StgMutClosure*)R1.cl);
362
363   TICK_RET_UNBOXED_TUP(1);
364   RET_P(R1.p);
365   FE_
366 }
367
368 /* -----------------------------------------------------------------------------
369    Weak Pointer Primitives
370    -------------------------------------------------------------------------- */
371
372 FN_(mkWeakzh_fast)
373 {
374   /* R1.p = key
375      R2.p = value
376      R3.p = finalizer (or NULL)
377   */
378   StgWeak *w;
379   FB_
380
381   if (R3.cl == NULL) {
382     R3.cl = &stg_NO_FINALIZER_closure;
383   }
384
385   HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
386   TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,  // +1 is for the link field
387                   sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
388   CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
389
390   w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
391   SET_HDR(w, &stg_WEAK_info, CCCS);
392
393   w->key        = R1.cl;
394   w->value      = R2.cl;
395   w->finalizer  = R3.cl;
396
397   w->link       = weak_ptr_list;
398   weak_ptr_list = w;
399   IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
400
401   TICK_RET_UNBOXED_TUP(1);
402   RET_P(w);
403   FE_
404 }
405
406 FN_(finalizzeWeakzh_fast)
407 {
408   /* R1.p = weak ptr
409    */
410   StgDeadWeak *w;
411   StgClosure *f;
412   FB_
413   TICK_RET_UNBOXED_TUP(0);
414   w = (StgDeadWeak *)R1.p;
415
416   /* already dead? */
417   if (w->header.info == &stg_DEAD_WEAK_info) {
418       RET_NP(0,&stg_NO_FINALIZER_closure);
419   }
420
421   /* kill it */
422 #ifdef PROFILING
423   // @LDV profiling
424   // A weak pointer is inherently used, so we do not need to call
425   // LDV_recordDead_FILL_SLOP_DYNAMIC():
426   //    LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w);
427   // or, LDV_recordDead():
428   //    LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader));
429   // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as 
430   // large as weak pointers, so there is no need to fill the slop, either.
431   // See stg_DEAD_WEAK_info in StgMiscClosures.hc.
432 #endif
433   //
434   // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
435   //
436   w->header.info = &stg_DEAD_WEAK_info;
437 #ifdef PROFILING
438   // @LDV profiling
439   LDV_recordCreate((StgClosure *)w);
440 #endif
441   f = ((StgWeak *)w)->finalizer;
442   w->link = ((StgWeak *)w)->link;
443
444   /* return the finalizer */
445   if (f == &stg_NO_FINALIZER_closure) {
446       RET_NP(0,&stg_NO_FINALIZER_closure);
447   } else {
448       RET_NP(1,f);
449   }
450   FE_
451 }
452
453 FN_(deRefWeakzh_fast)
454 {
455   /* R1.p = weak ptr */
456   StgWeak* w;
457   I_       code;
458   P_       val;
459   FB_
460   w = (StgWeak*)R1.p;
461   if (w->header.info == &stg_WEAK_info) {
462     code = 1;
463     val = (P_)((StgWeak *)w)->value;
464   } else {
465     code = 0;
466     val = (P_)w;
467   }
468   RET_NP(code,val);
469   FE_
470 }
471
472 /* -----------------------------------------------------------------------------
473    Arbitrary-precision Integer operations.
474    -------------------------------------------------------------------------- */
475
476 FN_(int2Integerzh_fast)
477 {
478    /* arguments: R1 = Int# */
479
480    I_ val, s;           /* to avoid aliasing */
481    StgArrWords* p;      /* address of array result */
482    FB_
483
484    val = R1.i;
485    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
486    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
487    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
488
489    p = (StgArrWords *)Hp - 1;
490    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
491
492    /* mpz_set_si is inlined here, makes things simpler */
493    if (val < 0) { 
494         s  = -1;
495         *Hp = -val;
496    } else if (val > 0) {
497         s = 1;
498         *Hp = val;
499    } else {
500         s = 0;
501    }
502
503    /* returns (# size  :: Int#, 
504                  data  :: ByteArray# 
505                #)
506    */
507    TICK_RET_UNBOXED_TUP(2);
508    RET_NP(s,p);
509    FE_
510 }
511
512 FN_(word2Integerzh_fast)
513 {
514    /* arguments: R1 = Word# */
515
516    W_ val;              /* to avoid aliasing */
517    I_  s;
518    StgArrWords* p;      /* address of array result */
519    FB_
520
521    val = R1.w;
522    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
523    TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
524    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
525
526    p = (StgArrWords *)Hp - 1;
527    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
528
529    if (val != 0) {
530         s = 1;
531         *Hp = val;
532    } else {
533         s = 0;
534    }
535
536    /* returns (# size  :: Int#, 
537                  data  :: ByteArray# 
538                #)
539    */
540    TICK_RET_UNBOXED_TUP(2);
541    RET_NP(s,p);
542    FE_
543 }
544
545
546 /*
547  * 'long long' primops for converting to/from Integers.
548  */
549
550 #ifdef SUPPORT_LONG_LONGS
551
552 FN_(int64ToIntegerzh_fast)
553 {
554    /* arguments: L1 = Int64# */
555
556    StgInt64  val; /* to avoid aliasing */
557    W_ hi;
558    I_  s, neg, words_needed;
559    StgArrWords* p;      /* address of array result */
560    FB_
561
562    val = (LI_)L1;
563    neg = 0;
564
565    if ( val >= 0x100000000LL || val <= -0x100000000LL )  { 
566        words_needed = 2;
567    } else { 
568        /* minimum is one word */
569        words_needed = 1;
570    }
571    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
572    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
573    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
574
575    p = (StgArrWords *)(Hp-words_needed+1) - 1;
576    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
577
578    if ( val < 0LL ) {
579      neg = 1;
580      val = -val;
581    }
582
583    hi = (W_)((LW_)val / 0x100000000ULL);
584
585    if ( words_needed == 2 )  { 
586       s = 2;
587       Hp[-1] = (W_)val;
588       Hp[0] = hi;
589    } else if ( val != 0 ) {
590       s = 1;
591       Hp[0] = (W_)val;
592    }  else /* val==0 */   {
593       s = 0;
594    }
595    s = ( neg ? -s : s );
596
597    /* returns (# size  :: Int#, 
598                  data  :: ByteArray# 
599                #)
600    */
601    TICK_RET_UNBOXED_TUP(2);
602    RET_NP(s,p);
603    FE_
604 }
605
606 FN_(word64ToIntegerzh_fast)
607 {
608    /* arguments: L1 = Word64# */
609
610    StgWord64 val; /* to avoid aliasing */
611    StgWord hi;
612    I_  s, words_needed;
613    StgArrWords* p;      /* address of array result */
614    FB_
615
616    val = (LW_)L1;
617    if ( val >= 0x100000000ULL ) {
618       words_needed = 2;
619    } else {
620       words_needed = 1;
621    }
622    HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
623    TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
624    CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
625
626    p = (StgArrWords *)(Hp-words_needed+1) - 1;
627    SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
628
629    hi = (W_)((LW_)val / 0x100000000ULL);
630    if ( val >= 0x100000000ULL ) { 
631      s = 2;
632      Hp[-1] = ((W_)val);
633      Hp[0]  = (hi);
634    } else if ( val != 0 )      {
635       s = 1;
636       Hp[0] = ((W_)val);
637    } else /* val==0 */         {
638       s = 0;
639    }
640
641    /* returns (# size  :: Int#, 
642                  data  :: ByteArray# 
643                #)
644    */
645    TICK_RET_UNBOXED_TUP(2);
646    RET_NP(s,p);
647    FE_
648 }
649
650
651 #endif /* SUPPORT_LONG_LONGS */
652
653 /* ToDo: this is shockingly inefficient */
654
655 #define GMP_TAKE2_RET1(name,mp_fun)                                     \
656 FN_(name)                                                               \
657 {                                                                       \
658   MP_INT arg1, arg2, result;                                            \
659   I_ s1, s2;                                                            \
660   StgArrWords* d1;                                                      \
661   StgArrWords* d2;                                                      \
662   FB_                                                                   \
663                                                                         \
664   /* call doYouWantToGC() */                                            \
665   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
666                                                                         \
667   d1 = (StgArrWords *)R2.p;                                             \
668   s1 = R1.i;                                                            \
669   d2 = (StgArrWords *)R4.p;                                             \
670   s2 = R3.i;                                                            \
671                                                                         \
672   arg1._mp_alloc        = d1->words;                                    \
673   arg1._mp_size         = (s1);                                         \
674   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
675   arg2._mp_alloc        = d2->words;                                    \
676   arg2._mp_size         = (s2);                                         \
677   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
678                                                                         \
679   STGCALL1(mpz_init,&result);                                           \
680                                                                         \
681   /* Perform the operation */                                           \
682   STGCALL3(mp_fun,&result,&arg1,&arg2);                                 \
683                                                                         \
684   TICK_RET_UNBOXED_TUP(2);                                              \
685   RET_NP(result._mp_size,                                               \
686          result._mp_d-sizeofW(StgArrWords));                            \
687   FE_                                                                   \
688 }
689
690 #define GMP_TAKE1_RET1(name,mp_fun)                                     \
691 FN_(name)                                                               \
692 {                                                                       \
693   MP_INT arg1, result;                                                  \
694   I_ s1;                                                                \
695   StgArrWords* d1;                                                      \
696   FB_                                                                   \
697                                                                         \
698   /* call doYouWantToGC() */                                            \
699   MAYBE_GC(R2_PTR, name);                                               \
700                                                                         \
701   d1 = (StgArrWords *)R2.p;                                             \
702   s1 = R1.i;                                                            \
703                                                                         \
704   arg1._mp_alloc        = d1->words;                                    \
705   arg1._mp_size         = (s1);                                         \
706   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
707                                                                         \
708   STGCALL1(mpz_init,&result);                                           \
709                                                                         \
710   /* Perform the operation */                                           \
711   STGCALL2(mp_fun,&result,&arg1);                                       \
712                                                                         \
713   TICK_RET_UNBOXED_TUP(2);                                              \
714   RET_NP(result._mp_size,                                               \
715          result._mp_d-sizeofW(StgArrWords));                            \
716   FE_                                                                   \
717 }
718
719 #define GMP_TAKE2_RET2(name,mp_fun)                                     \
720 FN_(name)                                                               \
721 {                                                                       \
722   MP_INT arg1, arg2, result1, result2;                                  \
723   I_ s1, s2;                                                            \
724   StgArrWords* d1;                                                      \
725   StgArrWords* d2;                                                      \
726   FB_                                                                   \
727                                                                         \
728   /* call doYouWantToGC() */                                            \
729   MAYBE_GC(R2_PTR | R4_PTR, name);                                      \
730                                                                         \
731   d1 = (StgArrWords *)R2.p;                                             \
732   s1 = R1.i;                                                            \
733   d2 = (StgArrWords *)R4.p;                                             \
734   s2 = R3.i;                                                            \
735                                                                         \
736   arg1._mp_alloc        = d1->words;                                    \
737   arg1._mp_size         = (s1);                                         \
738   arg1._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d1));     \
739   arg2._mp_alloc        = d2->words;                                    \
740   arg2._mp_size         = (s2);                                         \
741   arg2._mp_d            = (unsigned long int *) (BYTE_ARR_CTS(d2));     \
742                                                                         \
743   STGCALL1(mpz_init,&result1);                                          \
744   STGCALL1(mpz_init,&result2);                                          \
745                                                                         \
746   /* Perform the operation */                                           \
747   STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2);                       \
748                                                                         \
749   TICK_RET_UNBOXED_TUP(4);                                              \
750   RET_NPNP(result1._mp_size,                                            \
751            result1._mp_d-sizeofW(StgArrWords),                          \
752            result2._mp_size,                                            \
753            result2._mp_d-sizeofW(StgArrWords));                         \
754   FE_                                                                   \
755 }
756
757 GMP_TAKE2_RET1(plusIntegerzh_fast,     mpz_add);
758 GMP_TAKE2_RET1(minusIntegerzh_fast,    mpz_sub);
759 GMP_TAKE2_RET1(timesIntegerzh_fast,    mpz_mul);
760 GMP_TAKE2_RET1(gcdIntegerzh_fast,      mpz_gcd);
761 GMP_TAKE2_RET1(quotIntegerzh_fast,     mpz_tdiv_q);
762 GMP_TAKE2_RET1(remIntegerzh_fast,      mpz_tdiv_r);
763 GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
764 GMP_TAKE2_RET1(andIntegerzh_fast,      mpz_and);
765 GMP_TAKE2_RET1(orIntegerzh_fast,       mpz_ior);
766 GMP_TAKE2_RET1(xorIntegerzh_fast,      mpz_xor);
767 GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
768
769 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
770 GMP_TAKE2_RET2(divModIntegerzh_fast,  mpz_fdiv_qr);
771
772
773 FN_(gcdIntzh_fast)
774 {
775   /* R1 = the first Int#; R2 = the second Int# */
776   mp_limb_t aa;
777   I_ r;
778   FB_
779   aa = (mp_limb_t)(R1.i);
780   r = RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(R2.i));
781
782   R1.i = r;
783   /* Result parked in R1, return via info-pointer at TOS */
784   JMP_(ENTRY_CODE(Sp[0]));
785   FE_
786 }
787
788 FN_(gcdIntegerIntzh_fast)
789 {
790   /* R1 = s1; R2 = d1; R3 = the int */
791   I_ r;
792   FB_
793   r = RET_STGCALL3(StgInt,mpn_gcd_1,(mp_limb_t *)(BYTE_ARR_CTS(R2.p)), R1.i, R3.i);
794
795   R1.i = r;
796   /* Result parked in R1, return via info-pointer at TOS */
797   JMP_(ENTRY_CODE(Sp[0]));
798   FE_
799 }
800
801 FN_(cmpIntegerIntzh_fast)
802 {
803   /* R1 = s1; R2 = d1; R3 = the int */
804   I_ usize;
805   I_ vsize;
806   I_ v_digit;
807   mp_limb_t u_digit;
808   FB_
809
810   usize = R1.i;
811   vsize = 0;
812   v_digit = R3.i;
813
814   // paraphrased from mpz_cmp_si() in the GMP sources
815   if (v_digit > 0) {
816       vsize = 1;
817   } else if (v_digit < 0) {
818       vsize = -1;
819       v_digit = -v_digit;
820   }
821
822   if (usize != vsize) {
823     R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
824   }
825
826   if (usize == 0) {
827     R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
828   }
829
830   u_digit = *(mp_limb_t *)(BYTE_ARR_CTS(R2.p));
831
832   if (u_digit == (mp_limb_t) (unsigned long) v_digit) {
833     R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
834   }
835
836   if (u_digit > (mp_limb_t) (unsigned long) v_digit) {
837     R1.i = usize; 
838   } else {
839     R1.i = -usize; 
840   }
841
842   JMP_(ENTRY_CODE(Sp[0]));
843   FE_
844 }
845
846 FN_(cmpIntegerzh_fast)
847 {
848   /* R1 = s1; R2 = d1; R3 = s2; R4 = d2 */
849   I_ usize;
850   I_ vsize;
851   I_ size;
852   StgPtr up, vp;
853   int cmp;
854   FB_
855
856   // paraphrased from mpz_cmp() in the GMP sources
857   usize = R1.i;
858   vsize = R3.i;
859
860   if (usize != vsize) {
861     R1.i = usize - vsize; JMP_(ENTRY_CODE(Sp[0]));
862   }
863
864   if (usize == 0) {
865     R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
866   }
867
868   size = abs(usize);
869
870   up = BYTE_ARR_CTS(R2.p);
871   vp = BYTE_ARR_CTS(R4.p);
872
873   cmp = RET_STGCALL3(I_, mpn_cmp, (mp_limb_t *)up, (mp_limb_t *)vp, size);
874
875   if (cmp == 0) {
876     R1.i = 0; JMP_(ENTRY_CODE(Sp[0]));
877   }
878
879   if ((cmp < 0) == (usize < 0)) {
880     R1.i = 1;
881   } else {
882     R1.i = (-1); 
883   }
884   /* Result parked in R1, return via info-pointer at TOS */
885   JMP_(ENTRY_CODE(Sp[0]));
886   FE_
887 }
888
889 FN_(integer2Intzh_fast)
890 {
891   /* R1 = s; R2 = d */
892   I_ r, s;
893   FB_
894   s = R1.i;
895   if (s == 0)
896     r = 0;
897   else {
898     r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
899     if (s < 0) r = -r;
900   }
901   /* Result parked in R1, return via info-pointer at TOS */
902   R1.i = r;
903   JMP_(ENTRY_CODE(Sp[0]));
904   FE_
905 }
906
907 FN_(integer2Wordzh_fast)
908 {
909   /* R1 = s; R2 = d */
910   I_ s;
911   W_ r;
912   FB_
913   s = R1.i;
914   if (s == 0)
915     r = 0;
916   else {
917     r = ((mp_limb_t *) (BYTE_ARR_CTS(R2.p)))[0];
918     if (s < 0) r = -r;
919   }
920   /* Result parked in R1, return via info-pointer at TOS */
921   R1.w = r;
922   JMP_(ENTRY_CODE(Sp[0]));
923   FE_
924 }
925
926
927 FN_(decodeFloatzh_fast)
928
929   MP_INT mantissa;
930   I_ exponent;
931   StgArrWords* p;
932   StgFloat arg;
933   FB_
934
935   /* arguments: F1 = Float# */
936   arg = F1;
937
938   HP_CHK_GEN_TICKY(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
939   TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
940   CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
941
942   /* Be prepared to tell Lennart-coded __decodeFloat    */
943   /* where mantissa._mp_d can be put (it does not care about the rest) */
944   p = (StgArrWords *)Hp - 1;
945   SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
946   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
947
948   /* Perform the operation */
949   STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
950
951   /* returns: (Int# (expn), Int#, ByteArray#) */
952   TICK_RET_UNBOXED_TUP(3);
953   RET_NNP(exponent,mantissa._mp_size,p);
954   FE_
955 }
956
957 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
958 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
959
960 FN_(decodeDoublezh_fast)
961 { MP_INT mantissa;
962   I_ exponent;
963   StgDouble arg;
964   StgArrWords* p;
965   FB_
966
967   /* arguments: D1 = Double# */
968   arg = D1;
969
970   HP_CHK_GEN_TICKY(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
971   TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
972   CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
973
974   /* Be prepared to tell Lennart-coded __decodeDouble   */
975   /* where mantissa.d can be put (it does not care about the rest) */
976   p = (StgArrWords *)(Hp-ARR_SIZE+1);
977   SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
978   mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
979
980   /* Perform the operation */
981   STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
982
983   /* returns: (Int# (expn), Int#, ByteArray#) */
984   TICK_RET_UNBOXED_TUP(3);
985   RET_NNP(exponent,mantissa._mp_size,p);
986   FE_
987 }
988
989 /* -----------------------------------------------------------------------------
990  * Concurrency primitives
991  * -------------------------------------------------------------------------- */
992
993 FN_(forkzh_fast)
994 {
995   FB_
996   /* args: R1 = closure to spark */
997   
998   MAYBE_GC(R1_PTR, forkzh_fast);
999
1000   /* create it right now, return ThreadID in R1 */
1001   R1.t = RET_STGCALL2(StgTSO *, createIOThread, 
1002                      RtsFlags.GcFlags.initialStkSize, R1.cl);
1003   STGCALL1(scheduleThread, R1.t);
1004       
1005   /* switch at the earliest opportunity */ 
1006   context_switch = 1;
1007   
1008   RET_P(R1.t);
1009   FE_
1010 }
1011
1012 FN_(forkProcesszh_fast)
1013 {
1014   pid_t pid;
1015
1016   FB_
1017   /* args: none */
1018   /* result: Pid */
1019
1020   R1.i = RET_STGCALL1(StgInt, forkProcess, CurrentTSO);
1021
1022   JMP_(ENTRY_CODE(Sp[0]));
1023
1024   FE_
1025 }
1026
1027 FN_(yieldzh_fast)
1028 {
1029   FB_
1030   JMP_(stg_yield_noregs);
1031   FE_
1032 }
1033
1034 FN_(myThreadIdzh_fast)
1035 {
1036   /* no args. */
1037   FB_
1038   RET_P((P_)CurrentTSO);
1039   FE_
1040 }
1041
1042 FN_(labelThreadzh_fast)
1043 {
1044   FB_
1045   /* args: R1.p = Addr# */
1046 #ifdef DEBUG
1047   STGCALL2(labelThread,CurrentTSO,(char *)R1.p);
1048 #endif
1049   FE_
1050 }
1051
1052
1053 /* -----------------------------------------------------------------------------
1054  * MVar primitives
1055  *
1056  * take & putMVar work as follows.  Firstly, an important invariant:
1057  *
1058  *    If the MVar is full, then the blocking queue contains only
1059  *    threads blocked on putMVar, and if the MVar is empty then the
1060  *    blocking queue contains only threads blocked on takeMVar.
1061  *
1062  * takeMvar:
1063  *    MVar empty : then add ourselves to the blocking queue
1064  *    MVar full  : remove the value from the MVar, and
1065  *                 blocking queue empty     : return
1066  *                 blocking queue non-empty : perform the first blocked putMVar
1067  *                                            from the queue, and wake up the
1068  *                                            thread (MVar is now full again)
1069  *
1070  * putMVar is just the dual of the above algorithm.
1071  *
1072  * How do we "perform a putMVar"?  Well, we have to fiddle around with
1073  * the stack of the thread waiting to do the putMVar.  See
1074  * stg_block_putmvar and stg_block_takemvar in HeapStackCheck.c for
1075  * the stack layout, and the PerformPut and PerformTake macros below.
1076  *
1077  * It is important that a blocked take or put is woken up with the
1078  * take/put already performed, because otherwise there would be a
1079  * small window of vulnerability where the thread could receive an
1080  * exception and never perform its take or put, and we'd end up with a
1081  * deadlock.
1082  *
1083  * -------------------------------------------------------------------------- */
1084
1085 FN_(isEmptyMVarzh_fast)
1086 {
1087   /* args: R1 = MVar closure */
1088   I_ r;
1089   FB_
1090   r = (I_)((GET_INFO((StgMVar*)(R1.p))) == &stg_EMPTY_MVAR_info);
1091   RET_N(r);
1092   FE_
1093 }
1094
1095
1096 FN_(newMVarzh_fast)
1097 {
1098   StgMVar *mvar;
1099
1100   FB_
1101   /* args: none */
1102
1103   HP_CHK_GEN_TICKY(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
1104   TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
1105                   1, 0);
1106   CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
1107   
1108   mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
1109   SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
1110   mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1111   mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1112
1113   TICK_RET_UNBOXED_TUP(1);
1114   RET_P(mvar);
1115   FE_
1116 }
1117
1118 /* If R1 isn't available, pass it on the stack */
1119 #ifdef REG_R1
1120 #define PerformTake(tso, value) ({              \
1121     (tso)->sp[1] = (W_)value;                   \
1122     (tso)->sp[0] = (W_)&stg_gc_unpt_r1_info;    \
1123   })
1124 #else
1125 #define PerformTake(tso, value) ({              \
1126     (tso)->sp[1] = (W_)value;                   \
1127     (tso)->sp[0] = (W_)&stg_ut_1_0_unreg_info;  \
1128   })
1129 #endif
1130
1131
1132 #define PerformPut(tso) ({                              \
1133     StgClosure *val = (StgClosure *)(tso)->sp[2];       \
1134     (tso)->sp[2] = (W_)&stg_gc_noregs_info;             \
1135     (tso)->sp += 2;                                     \
1136     val;                                                \
1137   })
1138
1139 FN_(takeMVarzh_fast)
1140 {
1141   StgMVar *mvar;
1142   StgClosure *val;
1143   const StgInfoTable *info;
1144
1145   FB_
1146   /* args: R1 = MVar closure */
1147
1148   mvar = (StgMVar *)R1.p;
1149
1150 #ifdef SMP
1151   info = LOCK_CLOSURE(mvar);
1152 #else
1153   info = GET_INFO(mvar);
1154 #endif
1155
1156   /* If the MVar is empty, put ourselves on its blocking queue,
1157    * and wait until we're woken up.
1158    */
1159   if (info == &stg_EMPTY_MVAR_info) {
1160     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1161       mvar->head = CurrentTSO;
1162     } else {
1163       mvar->tail->link = CurrentTSO;
1164     }
1165     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1166     CurrentTSO->why_blocked = BlockedOnMVar;
1167     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1168     mvar->tail = CurrentTSO;
1169
1170 #ifdef SMP
1171     /* unlock the MVar */
1172     mvar->header.info = &stg_EMPTY_MVAR_info;
1173 #endif
1174     JMP_(stg_block_takemvar);
1175   }
1176
1177   /* we got the value... */
1178   val = mvar->value;
1179
1180   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1181       /* There are putMVar(s) waiting... 
1182        * wake up the first thread on the queue
1183        */
1184       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1185
1186       /* actually perform the putMVar for the thread that we just woke up */
1187       mvar->value = PerformPut(mvar->head);
1188
1189 #if defined(GRAN) || defined(PAR)
1190       /* ToDo: check 2nd arg (mvar) is right */
1191       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1192 #else
1193       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1194 #endif
1195       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1196           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1197       }
1198 #ifdef SMP
1199       /* unlock in the SMP case */
1200       SET_INFO(mvar,&stg_FULL_MVAR_info);
1201 #endif
1202       TICK_RET_UNBOXED_TUP(1);
1203       RET_P(val);
1204   } else {
1205       /* No further putMVars, MVar is now empty */
1206
1207       /* do this last... we might have locked the MVar in the SMP case,
1208        * and writing the info pointer will unlock it.
1209        */
1210       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1211       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1212       TICK_RET_UNBOXED_TUP(1);
1213       RET_P(val);
1214   }
1215   FE_
1216 }
1217
1218 FN_(tryTakeMVarzh_fast)
1219 {
1220   StgMVar *mvar;
1221   StgClosure *val;
1222   const StgInfoTable *info;
1223
1224   FB_
1225   /* args: R1 = MVar closure */
1226
1227   mvar = (StgMVar *)R1.p;
1228
1229 #ifdef SMP
1230   info = LOCK_CLOSURE(mvar);
1231 #else
1232   info = GET_INFO(mvar);
1233 #endif
1234
1235   if (info == &stg_EMPTY_MVAR_info) {
1236
1237 #ifdef SMP
1238       /* unlock the MVar */
1239       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1240 #endif
1241
1242       /* HACK: we need a pointer to pass back, 
1243        * so we abuse NO_FINALIZER_closure
1244        */
1245       RET_NP(0, &stg_NO_FINALIZER_closure);
1246   }
1247
1248   /* we got the value... */
1249   val = mvar->value;
1250
1251   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1252       /* There are putMVar(s) waiting... 
1253        * wake up the first thread on the queue
1254        */
1255       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1256
1257       /* actually perform the putMVar for the thread that we just woke up */
1258       mvar->value = PerformPut(mvar->head);
1259
1260 #if defined(GRAN) || defined(PAR)
1261       /* ToDo: check 2nd arg (mvar) is right */
1262       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1263 #else
1264       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1265 #endif
1266       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1267           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1268       }
1269 #ifdef SMP
1270       /* unlock in the SMP case */
1271       SET_INFO(mvar,&stg_FULL_MVAR_info);
1272 #endif
1273   } else {
1274       /* No further putMVars, MVar is now empty */
1275       mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
1276
1277       /* do this last... we might have locked the MVar in the SMP case,
1278        * and writing the info pointer will unlock it.
1279        */
1280       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1281   }
1282
1283   TICK_RET_UNBOXED_TUP(1);
1284   RET_NP((I_)1, val);
1285   FE_
1286 }
1287
1288 FN_(putMVarzh_fast)
1289 {
1290   StgMVar *mvar;
1291   const StgInfoTable *info;
1292
1293   FB_
1294   /* args: R1 = MVar, R2 = value */
1295
1296   mvar = (StgMVar *)R1.p;
1297
1298 #ifdef SMP
1299   info = LOCK_CLOSURE(mvar);
1300 #else
1301   info = GET_INFO(mvar);
1302 #endif
1303
1304   if (info == &stg_FULL_MVAR_info) {
1305     if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1306       mvar->head = CurrentTSO;
1307     } else {
1308       mvar->tail->link = CurrentTSO;
1309     }
1310     CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1311     CurrentTSO->why_blocked = BlockedOnMVar;
1312     CurrentTSO->block_info.closure = (StgClosure *)mvar;
1313     mvar->tail = CurrentTSO;
1314
1315 #ifdef SMP
1316     /* unlock the MVar */
1317     SET_INFO(mvar,&stg_FULL_MVAR_info);
1318 #endif
1319     JMP_(stg_block_putmvar);
1320   }
1321   
1322   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1323       /* There are takeMVar(s) waiting: wake up the first one
1324        */
1325       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1326
1327       /* actually perform the takeMVar */
1328       PerformTake(mvar->head, R2.cl);
1329       
1330 #if defined(GRAN) || defined(PAR)
1331       /* ToDo: check 2nd arg (mvar) is right */
1332       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1333 #else
1334       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1335 #endif
1336       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1337           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1338       }
1339 #ifdef SMP
1340       /* unlocks the MVar in the SMP case */
1341       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1342 #endif
1343       JMP_(ENTRY_CODE(Sp[0]));
1344   } else {
1345       /* No further takes, the MVar is now full. */
1346       mvar->value = R2.cl;
1347       /* unlocks the MVar in the SMP case */
1348       SET_INFO(mvar,&stg_FULL_MVAR_info);
1349       JMP_(ENTRY_CODE(Sp[0]));
1350   }
1351
1352   /* ToDo: yield afterward for better communication performance? */
1353   FE_
1354 }
1355
1356 FN_(tryPutMVarzh_fast)
1357 {
1358   StgMVar *mvar;
1359   const StgInfoTable *info;
1360
1361   FB_
1362   /* args: R1 = MVar, R2 = value */
1363
1364   mvar = (StgMVar *)R1.p;
1365
1366 #ifdef SMP
1367   info = LOCK_CLOSURE(mvar);
1368 #else
1369   info = GET_INFO(mvar);
1370 #endif
1371
1372   if (info == &stg_FULL_MVAR_info) {
1373
1374 #ifdef SMP
1375     /* unlock the MVar */
1376     mvar->header.info = &stg_FULL_MVAR_info;
1377 #endif
1378
1379     RET_N(0);
1380   }
1381   
1382   if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1383       /* There are takeMVar(s) waiting: wake up the first one
1384        */
1385       ASSERT(mvar->head->why_blocked == BlockedOnMVar);
1386
1387       /* actually perform the takeMVar */
1388       PerformTake(mvar->head, R2.cl);
1389       
1390 #if defined(GRAN) || defined(PAR)
1391       /* ToDo: check 2nd arg (mvar) is right */
1392       mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
1393 #else
1394       mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
1395 #endif
1396       if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
1397           mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
1398       }
1399 #ifdef SMP
1400       /* unlocks the MVar in the SMP case */
1401       SET_INFO(mvar,&stg_EMPTY_MVAR_info);
1402 #endif
1403       JMP_(ENTRY_CODE(Sp[0]));
1404   } else {
1405       /* No further takes, the MVar is now full. */
1406       mvar->value = R2.cl;
1407       /* unlocks the MVar in the SMP case */
1408       SET_INFO(mvar,&stg_FULL_MVAR_info);
1409       JMP_(ENTRY_CODE(Sp[0]));
1410   }
1411
1412   /* ToDo: yield afterward for better communication performance? */
1413   FE_
1414 }
1415
1416 /* -----------------------------------------------------------------------------
1417    Stable pointer primitives
1418    -------------------------------------------------------------------------  */
1419
1420 FN_(makeStableNamezh_fast)
1421 {
1422   StgWord index;
1423   StgStableName *sn_obj;
1424   FB_
1425
1426   HP_CHK_GEN_TICKY(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
1427   TICK_ALLOC_PRIM(sizeofW(StgHeader), 
1428                   sizeofW(StgStableName)-sizeofW(StgHeader), 0);
1429   CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
1430   
1431   index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
1432
1433   /* Is there already a StableName for this heap object? */
1434   if (stable_ptr_table[index].sn_obj == NULL) {
1435     sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
1436     SET_HDR(sn_obj,&stg_STABLE_NAME_info,CCCS);
1437     sn_obj->sn = index;
1438     stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
1439   } else {
1440     (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
1441   }
1442
1443   TICK_RET_UNBOXED_TUP(1);
1444   RET_P(sn_obj);
1445 }
1446
1447
1448 FN_(makeStablePtrzh_fast)
1449 {
1450   /* Args: R1 = a */
1451   StgStablePtr sp;
1452   FB_
1453   MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
1454   sp = RET_STGCALL1(StgStablePtr,getStablePtr,R1.p);
1455   RET_N(sp);
1456   FE_
1457 }
1458
1459 FN_(deRefStablePtrzh_fast)
1460 {
1461   /* Args: R1 = the stable ptr */
1462   P_ r;
1463   StgStablePtr sp;
1464   FB_
1465   sp = (StgStablePtr)R1.w;
1466   r = stable_ptr_table[(StgWord)sp].addr;
1467   RET_P(r);
1468   FE_
1469 }
1470
1471 /* -----------------------------------------------------------------------------
1472    Bytecode object primitives
1473    -------------------------------------------------------------------------  */
1474
1475 FN_(newBCOzh_fast)
1476 {
1477   /* R1.p = instrs
1478      R2.p = literals
1479      R3.p = ptrs
1480      R4.p = itbls
1481   */
1482   StgBCO *bco;
1483   FB_
1484
1485   HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
1486   TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
1487   CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
1488   bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
1489   SET_HDR(bco, &stg_BCO_info, CCCS);
1490
1491   bco->instrs     = (StgArrWords*)R1.cl;
1492   bco->literals   = (StgArrWords*)R2.cl;
1493   bco->ptrs       = (StgMutArrPtrs*)R3.cl;
1494   bco->itbls      = (StgArrWords*)R4.cl;
1495
1496   TICK_RET_UNBOXED_TUP(1);
1497   RET_P(bco);
1498   FE_
1499 }
1500
1501 FN_(mkApUpd0zh_fast)
1502 {
1503   /* R1.p = the fn for the AP_UPD
1504   */
1505   StgAP_UPD* ap;
1506   FB_
1507   HP_CHK_GEN_TICKY(AP_sizeW(0), R1_PTR, mkApUpd0zh_fast,);
1508   TICK_ALLOC_PRIM(sizeofW(StgHeader), AP_sizeW(0)-sizeofW(StgHeader), 0);
1509   CCS_ALLOC(CCCS,AP_sizeW(0)); /* ccs prof */
1510   ap = (StgAP_UPD *) (Hp + 1 - AP_sizeW(0));
1511   SET_HDR(ap, &stg_AP_UPD_info, CCCS);
1512
1513   ap->n_args = 0;
1514   ap->fun = R1.cl;
1515
1516   TICK_RET_UNBOXED_TUP(1);
1517   RET_P(ap);
1518   FE_
1519 }
1520
1521 /* -----------------------------------------------------------------------------
1522    Thread I/O blocking primitives
1523    -------------------------------------------------------------------------- */
1524
1525 FN_(waitReadzh_fast)
1526 {
1527   FB_
1528     /* args: R1.i */
1529     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1530     CurrentTSO->why_blocked = BlockedOnRead;
1531     CurrentTSO->block_info.fd = R1.i;
1532     ACQUIRE_LOCK(&sched_mutex);
1533     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1534     RELEASE_LOCK(&sched_mutex);
1535     JMP_(stg_block_noregs);
1536   FE_
1537 }
1538
1539 FN_(waitWritezh_fast)
1540 {
1541   FB_
1542     /* args: R1.i */
1543     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1544     CurrentTSO->why_blocked = BlockedOnWrite;
1545     CurrentTSO->block_info.fd = R1.i;
1546     ACQUIRE_LOCK(&sched_mutex);
1547     APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
1548     RELEASE_LOCK(&sched_mutex);
1549     JMP_(stg_block_noregs);
1550   FE_
1551 }
1552
1553 FN_(delayzh_fast)
1554 {
1555   StgTSO *t, *prev;
1556   nat target;
1557   FB_
1558     /* args: R1.i */
1559     ASSERT(CurrentTSO->why_blocked == NotBlocked);
1560     CurrentTSO->why_blocked = BlockedOnDelay;
1561
1562     ACQUIRE_LOCK(&sched_mutex);
1563
1564     target = (R1.i / (TICK_MILLISECS*1000)) + getourtimeofday();
1565     CurrentTSO->block_info.target = target;
1566
1567     /* Insert the new thread in the sleeping queue. */
1568     prev = NULL;
1569     t = sleeping_queue;
1570     while (t != END_TSO_QUEUE && t->block_info.target < target) {
1571         prev = t;
1572         t = t->link;
1573     }
1574
1575     CurrentTSO->link = t;
1576     if (prev == NULL) {
1577         sleeping_queue = CurrentTSO;
1578     } else {
1579         prev->link = CurrentTSO;
1580     }
1581
1582     RELEASE_LOCK(&sched_mutex);
1583     JMP_(stg_block_noregs);
1584   FE_
1585 }
1586