1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.hc,v 1.30 1999/09/15 13:45:18 simonmar Exp $
4 * (c) The GHC Team, 1998-1999
6 * Primitive functions / data
8 * ---------------------------------------------------------------------------*/
15 #include "StgStartup.h"
20 #include "BlockAlloc.h" /* tmp */
21 #include "StablePriv.h"
22 #include "HeapStackCheck.h"
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
33 W_ GHC_ZCCCallable_static_info[0];
34 W_ GHC_ZCCReturnable_static_info[0];
37 /* -----------------------------------------------------------------------------
38 Macros for Hand-written primitives.
39 -------------------------------------------------------------------------- */
42 * Horrible macros for returning unboxed tuples.
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.
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.
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
57 /*------ All Regs available */
59 # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
60 # define RET_N(a) RET_P(a)
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)
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)
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]));
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]));
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]));
85 #if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
86 defined(REG_R4) || defined(REG_R3) || defined(REG_R2)
87 # error RET_n macros not defined for this setup.
90 /*------ 1 Register available */
92 # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
93 # define RET_N(a) RET_P(a)
95 # define RET_PP(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
96 JMP_(ENTRY_CODE(Sp[1]));
97 # define RET_NN(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
98 JMP_(ENTRY_CODE(Sp[2]));
99 # define RET_NP(a,b) RET_PP(a,b)
101 # define RET_PPP(a,b,c) \
102 R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
103 JMP_(ENTRY_CODE(Sp[2]));
104 # define RET_NNP(a,b,c) \
105 R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
106 JMP_(ENTRY_CODE(Sp[3]));
108 # define RET_NNNP(a,b,c,d) \
110 /* Sp[-5] = ARGTAG(1); */ \
112 /* Sp[-3] = ARGTAG(1); */ \
116 JMP_(ENTRY_CODE(Sp[5]));
118 # define RET_NPNP(a,b,c,d) \
121 /* Sp[-3] = ARGTAG(1); */ \
125 JMP_(ENTRY_CODE(Sp[4]));
127 # define RET_NNPNNP(a,b,c,d,e,f) \
131 /* Sp[-3] = ARGTAG(1); */ \
133 /* Sp[-5] = ARGTAG(1); */ \
136 /* Sp[-8] = ARGTAG(1); */ \
138 JMP_(ENTRY_CODE(Sp[8]));
140 #else /* 0 Regs available */
142 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
143 #define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
144 #define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
146 /* Here's how to construct these macros:
148 * N = number of N's in the name;
149 * P = number of P's in the name;
151 * while (nonNull(name)) {
152 * if (nextChar == 'P') {
163 # define RET_P(a) PUSH_P(1,a); PUSHED(1)
164 # define RET_N(a) PUSH_N(2,a); PUSHED(2)
166 # define RET_PP(a,b) PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
167 # define RET_NN(a,b) PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
168 # define RET_NP(a,b) PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
170 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
171 # define RET_NNP(a,b,c) PUSH_N(5,a); PUSH_N(3,b); PUSH_P(1,c); PUSHED(5)
173 # 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)
174 # 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)
175 # 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)
182 /*-----------------------------------------------------------------------------
185 Basically just new*Array - the others are all inline macros.
187 The size arg is always passed in R1, and the result returned in R1.
189 The slow entry point is for returning from a heap check, the saved
190 size argument must be re-loaded from the stack.
191 -------------------------------------------------------------------------- */
193 /* for objects that are *less* than the size of a word, make sure we
194 * round up to the nearest word for the size of the array.
197 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
199 #define newByteArray(ty,scale) \
200 FN_(new##ty##Arrayzh_fast) \
202 W_ stuff_size, size, n; \
205 MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast); \
207 stuff_size = BYTES_TO_STGWORDS(n*scale); \
208 size = sizeofW(StgArrWords)+ stuff_size; \
209 p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
210 TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
211 SET_HDR(p, &ARR_WORDS_info, CCCS); \
212 p->words = stuff_size; \
213 TICK_RET_UNBOXED_TUP(1) \
218 newByteArray(Char, sizeof(C_))
219 newByteArray(Int, sizeof(I_));
220 newByteArray(Word, sizeof(W_));
221 newByteArray(Addr, sizeof(P_));
222 newByteArray(Float, sizeof(StgFloat));
223 newByteArray(Double, sizeof(StgDouble));
224 newByteArray(StablePtr, sizeof(StgStablePtr));
234 MAYBE_GC(R2_PTR,newArrayzh_fast);
236 size = sizeofW(StgMutArrPtrs) + n;
237 arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
238 TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
240 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
244 for (p = (P_)arr + sizeofW(StgMutArrPtrs);
245 p < (P_)arr + size; p++) {
249 TICK_RET_UNBOXED_TUP(1);
254 FN_(newMutVarzh_fast)
257 /* Args: R1.p = initialisation value */
260 HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
261 TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
262 CCS_ALLOC(CCCS,sizeofW(StgMutVar));
264 mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
265 SET_HDR(mv,&MUT_VAR_info,CCCS);
268 TICK_RET_UNBOXED_TUP(1);
273 /* -----------------------------------------------------------------------------
274 Foreign Object Primitives
276 -------------------------------------------------------------------------- */
279 FN_(makeForeignObjzh_fast)
281 /* R1.p = ptr to foreign object,
283 StgForeignObj *result;
286 HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
287 TICK_ALLOC_PRIM(sizeofW(StgHeader),
288 sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
289 CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
291 result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
292 SET_HDR(result,&FOREIGN_info,CCCS);
295 /* returns (# s#, ForeignObj# #) */
296 TICK_RET_UNBOXED_TUP(1);
302 /* These two are out-of-line for the benefit of the NCG */
303 FN_(unsafeThawArrayzh_fast)
306 SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
307 recordMutable((StgMutClosure*)R1.cl);
309 TICK_RET_UNBOXED_TUP(1);
314 /* -----------------------------------------------------------------------------
315 Weak Pointer Primitives
316 -------------------------------------------------------------------------- */
329 HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
330 TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
331 sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
332 CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
334 w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
335 SET_HDR(w, &WEAK_info, CCCS);
340 w->finalizer = R3.cl;
342 w->finalizer = &NO_FINALIZER_closure;
345 w->link = weak_ptr_list;
347 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
349 TICK_RET_UNBOXED_TUP(1);
354 FN_(finalizzeWeakzh_fast)
361 TICK_RET_UNBOXED_TUP(0);
362 w = (StgDeadWeak *)R1.p;
365 if (w->header.info == &DEAD_WEAK_info) {
366 RET_NP(0,&NO_FINALIZER_closure);
370 w->header.info = &DEAD_WEAK_info;
371 f = ((StgWeak *)w)->finalizer;
372 w->link = ((StgWeak *)w)->link;
374 /* return the finalizer */
375 if (f == &NO_FINALIZER_closure) {
376 RET_NP(0,&NO_FINALIZER_closure);
385 /* -----------------------------------------------------------------------------
386 Arbitrary-precision Integer operations.
387 -------------------------------------------------------------------------- */
389 FN_(int2Integerzh_fast)
391 /* arguments: R1 = Int# */
393 I_ val, s; /* to avoid aliasing */
394 StgArrWords* p; /* address of array result */
398 HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
399 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
400 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
402 p = (StgArrWords *)Hp - 1;
403 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
405 /* mpz_set_si is inlined here, makes things simpler */
409 } else if (val > 0) {
416 /* returns (# size :: Int#,
420 TICK_RET_UNBOXED_TUP(2);
425 FN_(word2Integerzh_fast)
427 /* arguments: R1 = Word# */
429 W_ val; /* to avoid aliasing */
431 StgArrWords* p; /* address of array result */
435 HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
436 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
437 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
439 p = (StgArrWords *)Hp - 1;
440 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
449 /* returns (# size :: Int#,
453 TICK_RET_UNBOXED_TUP(2);
458 FN_(addr2Integerzh_fast)
464 MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
466 /* args: R1 :: Addr# */
469 /* Perform the operation */
470 if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
473 /* returns (# size :: Int#,
477 TICK_RET_UNBOXED_TUP(2);
478 RET_NP(result._mp_size,
479 result._mp_d - sizeofW(StgArrWords));
484 * 'long long' primops for converting to/from Integers.
487 #ifdef SUPPORT_LONG_LONGS
489 FN_(int64ToIntegerzh_fast)
491 /* arguments: L1 = Int64# */
493 StgInt64 val; /* to avoid aliasing */
495 I_ s, neg, words_needed;
496 StgArrWords* p; /* address of array result */
502 if ( val >= 0x100000000LL || val <= -0x100000000LL ) {
505 /* minimum is one word */
508 HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
509 TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
510 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
512 p = (StgArrWords *)(Hp-words_needed+1) - 1;
513 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
520 hi = (W_)((LW_)val / 0x100000000ULL);
522 if ( words_needed == 2 ) {
526 } else if ( val != 0 ) {
529 } else /* val==0 */ {
532 s = ( neg ? -s : s );
534 /* returns (# size :: Int#,
538 TICK_RET_UNBOXED_TUP(2);
543 FN_(word64ToIntegerzh_fast)
545 /* arguments: L1 = Word64# */
547 StgWord64 val; /* to avoid aliasing */
550 StgArrWords* p; /* address of array result */
554 if ( val >= 0x100000000ULL ) {
559 HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
560 TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
561 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
563 p = (StgArrWords *)(Hp-words_needed+1) - 1;
564 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
566 hi = (W_)((LW_)val / 0x100000000ULL);
567 if ( val >= 0x100000000ULL ) {
571 } else if ( val != 0 ) {
574 } else /* val==0 */ {
578 /* returns (# size :: Int#,
582 TICK_RET_UNBOXED_TUP(2);
588 #endif /* HAVE_LONG_LONG */
590 /* ToDo: this is shockingly inefficient */
592 #define GMP_TAKE2_RET1(name,mp_fun) \
595 MP_INT arg1, arg2, result; \
601 /* call doYouWantToGC() */ \
602 MAYBE_GC(R2_PTR | R4_PTR, name); \
604 d1 = (StgArrWords *)R2.p; \
606 d2 = (StgArrWords *)R4.p; \
609 arg1._mp_alloc = d1->words; \
610 arg1._mp_size = (s1); \
611 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
612 arg2._mp_alloc = d2->words; \
613 arg2._mp_size = (s2); \
614 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
616 STGCALL1(mpz_init,&result); \
618 /* Perform the operation */ \
619 STGCALL3(mp_fun,&result,&arg1,&arg2); \
621 TICK_RET_UNBOXED_TUP(2); \
622 RET_NP(result._mp_size, \
623 result._mp_d-sizeofW(StgArrWords)); \
627 #define GMP_TAKE2_RET2(name,mp_fun) \
630 MP_INT arg1, arg2, result1, result2; \
636 /* call doYouWantToGC() */ \
637 MAYBE_GC(R2_PTR | R4_PTR, name); \
639 d1 = (StgArrWords *)R2.p; \
641 d2 = (StgArrWords *)R4.p; \
644 arg1._mp_alloc = d1->words; \
645 arg1._mp_size = (s1); \
646 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
647 arg2._mp_alloc = d2->words; \
648 arg2._mp_size = (s2); \
649 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
651 STGCALL1(mpz_init,&result1); \
652 STGCALL1(mpz_init,&result2); \
654 /* Perform the operation */ \
655 STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2); \
657 TICK_RET_UNBOXED_TUP(4); \
658 RET_NPNP(result1._mp_size, \
659 result1._mp_d-sizeofW(StgArrWords), \
661 result2._mp_d-sizeofW(StgArrWords)); \
665 GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add);
666 GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub);
667 GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul);
668 GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd);
670 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
671 GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
673 #ifndef FLOATS_AS_DOUBLES
674 FN_(decodeFloatzh_fast)
682 /* arguments: F1 = Float# */
685 HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
686 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
687 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
689 /* Be prepared to tell Lennart-coded __decodeFloat */
690 /* where mantissa._mp_d can be put (it does not care about the rest) */
691 p = (StgArrWords *)Hp - 1;
692 SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
693 mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
695 /* Perform the operation */
696 STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
698 /* returns: (Int# (expn), Int#, ByteArray#) */
699 TICK_RET_UNBOXED_TUP(3);
700 RET_NNP(exponent,mantissa._mp_size,p);
703 #endif /* !FLOATS_AS_DOUBLES */
705 #define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
706 #define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
708 FN_(decodeDoublezh_fast)
715 /* arguments: D1 = Double# */
718 HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
719 TICK_ALLOC_PRIM(sizeofW(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
720 CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
722 /* Be prepared to tell Lennart-coded __decodeDouble */
723 /* where mantissa.d can be put (it does not care about the rest) */
724 p = (StgArrWords *)(Hp-ARR_SIZE+1);
725 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
726 mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
728 /* Perform the operation */
729 STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
731 /* returns: (Int# (expn), Int#, ByteArray#) */
732 TICK_RET_UNBOXED_TUP(3);
733 RET_NNP(exponent,mantissa._mp_size,p);
737 /* -----------------------------------------------------------------------------
738 * Concurrency primitives
739 * -------------------------------------------------------------------------- */
744 /* args: R1 = closure to spark */
746 MAYBE_GC(R1_PTR, forkzh_fast);
748 /* create it right now, return ThreadID in R1 */
749 R1.t = RET_STGCALL2(StgTSO *, createIOThread,
750 RtsFlags.GcFlags.initialStkSize, R1.cl);
752 /* switch at the earliest opportunity */
755 JMP_(ENTRY_CODE(Sp[0]));
762 JMP_(stg_yield_noregs);
766 FN_(killThreadzh_fast)
769 /* args: R1.p = TSO to kill, R2.p = Exception */
771 /* The thread is dead, but the TSO sticks around for a while. That's why
772 * we don't have to explicitly remove it from any queues it might be on.
775 /* We might have killed ourselves. In which case, better be *very*
776 * careful. If the exception killed us, then return to the scheduler.
777 * If the exception went to a catch frame, we'll just continue from
780 if (R1.t == CurrentTSO) {
781 SaveThreadState(); /* inline! */
782 STGCALL2(raiseAsync, R1.t, R2.cl);
783 if (CurrentTSO->whatNext == ThreadKilled) {
784 R1.w = ThreadYielding;
788 if (CurrentTSO->whatNext == ThreadEnterGHC) {
791 JMP_(GET_ENTRY(R1.cl));
793 barf("killThreadzh_fast");
796 STGCALL2(raiseAsync, R1.t, R2.cl);
799 JMP_(ENTRY_CODE(Sp[0]));
810 HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
811 TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
813 CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
815 mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
816 SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
817 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
818 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
820 TICK_RET_UNBOXED_TUP(1);
831 /* args: R1 = MVar closure */
833 mvar = (StgMVar *)R1.p;
835 /* If the MVar is empty, put ourselves on its blocking queue,
836 * and wait until we're woken up.
838 if (GET_INFO(mvar) != &FULL_MVAR_info) {
839 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
840 mvar->head = CurrentTSO;
842 mvar->tail->link = CurrentTSO;
844 CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
845 CurrentTSO->why_blocked = BlockedOnMVar;
846 CurrentTSO->block_info.closure = (StgClosure *)mvar;
847 mvar->tail = CurrentTSO;
849 BLOCK(R1_PTR, takeMVarzh_fast);
852 SET_INFO(mvar,&EMPTY_MVAR_info);
854 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
856 TICK_RET_UNBOXED_TUP(1);
866 /* args: R1 = MVar, R2 = value */
868 mvar = (StgMVar *)R1.p;
869 if (GET_INFO(mvar) == &FULL_MVAR_info) {
870 fprintf(stderr, "putMVar#: MVar already full.\n");
871 stg_exit(EXIT_FAILURE);
874 SET_INFO(mvar,&FULL_MVAR_info);
877 /* wake up the first thread on the queue, it will continue with the
878 * takeMVar operation and mark the MVar empty again.
880 if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
881 ASSERT(mvar->head->why_blocked == BlockedOnMVar);
882 mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
883 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
884 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
888 /* ToDo: yield here for better communication performance? */
889 JMP_(ENTRY_CODE(Sp[0]));
893 /* -----------------------------------------------------------------------------
894 Stable pointer primitives
895 ------------------------------------------------------------------------- */
897 FN_(makeStableNamezh_fast)
900 StgStableName *sn_obj;
903 HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
904 TICK_ALLOC_PRIM(sizeofW(StgHeader),
905 sizeofW(StgStableName)-sizeofW(StgHeader), 0);
906 CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
908 index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
910 /* Is there already a StableName for this heap object? */
911 if (stable_ptr_table[index].sn_obj == NULL) {
912 sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
913 sn_obj->header.info = &STABLE_NAME_info;
915 stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
917 (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
920 TICK_RET_UNBOXED_TUP(1);
924 /* -----------------------------------------------------------------------------
925 Thread I/O blocking primitives
926 -------------------------------------------------------------------------- */
932 ASSERT(CurrentTSO->why_blocked == NotBlocked);
933 CurrentTSO->why_blocked = BlockedOnRead;
934 CurrentTSO->block_info.fd = R1.i;
935 PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
936 JMP_(stg_block_noregs);
940 FN_(waitWritezh_fast)
944 ASSERT(CurrentTSO->why_blocked == NotBlocked);
945 CurrentTSO->why_blocked = BlockedOnWrite;
946 CurrentTSO->block_info.fd = R1.i;
947 PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
948 JMP_(stg_block_noregs);
956 ASSERT(CurrentTSO->why_blocked == NotBlocked);
957 CurrentTSO->why_blocked = BlockedOnDelay;
959 /* Add on ticks_since_select, since these will be subtracted at
960 * the next awaitEvent call.
962 CurrentTSO->block_info.delay = R1.i + ticks_since_select;
964 PUSH_ON_BLOCKED_QUEUE(CurrentTSO);
965 JMP_(stg_block_noregs);
969 #endif /* COMPILER */