1 /* -----------------------------------------------------------------------------
2 * $Id: PrimOps.hc,v 1.21 1999/03/05 10:21:27 sof 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"
25 classes CCallable and CReturnable don't really exist, but the
26 compiler insists on generating dictionaries containing references
27 to GHC_ZcCCallable_static_info etc., so we provide dummy symbols
31 W_ GHC_ZCCCallable_static_info[0];
32 W_ GHC_ZCCReturnable_static_info[0];
35 /* -----------------------------------------------------------------------------
36 Macros for Hand-written primitives.
37 -------------------------------------------------------------------------- */
40 * Horrible macros for returning unboxed tuples.
42 * How an unboxed tuple is returned depends on two factors:
43 * - the number of real registers we have available
44 * - the boxedness of the returned fields.
46 * To return an unboxed tuple from a primitive operation, we have macros
47 * RET_<layout> where <layout> describes the boxedness of each field of the
48 * unboxed tuple: N indicates a non-pointer field, and P indicates a pointer.
50 * We only define the cases actually used, to avoid having too much
51 * garbage in this section. Warning: any bugs in here will be hard to
55 /*------ All Regs available */
57 # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
58 # define RET_N(a) RET_P(a)
60 # define RET_PP(a,b) R1.w = (W_)(a); R2.w = (W_)(b); JMP_(ENTRY_CODE(Sp[0]));
61 # define RET_NN(a,b) RET_PP(a,b)
62 # define RET_NP(a,b) RET_PP(a,b)
64 # define RET_PPP(a,b,c) \
65 R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); JMP_(ENTRY_CODE(Sp[0]));
66 # define RET_NNP(a,b,c) RET_PPP(a,b,c)
68 # define RET_NNNP(a,b,c,d) \
69 R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)d; \
70 JMP_(ENTRY_CODE(Sp[0]));
72 # define RET_NPNP(a,b,c,d) \
73 R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); R4.w = (W_)(d); \
74 JMP_(ENTRY_CODE(Sp[0]));
76 # define RET_NNPNNP(a,b,c,d,e,f) \
77 R1.w = (W_)(a); R2.w = (W_)(b); R3.w = (W_)(c); \
78 R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \
79 JMP_(ENTRY_CODE(Sp[0]));
83 #if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \
84 defined(REG_R4) || defined(REG_R3) || defined(REG_R2)
85 # error RET_n macros not defined for this setup.
88 /*------ 1 Register available */
90 # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0]));
91 # define RET_N(a) RET_P(a)
93 # define RET_PP(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 1; \
94 JMP_(ENTRY_CODE(Sp[1]));
95 # define RET_NN(a,b) R1.w = (W_)(a); Sp[-1] = (W_)(b); Sp -= 2; \
96 JMP_(ENTRY_CODE(Sp[2]));
97 # define RET_NP(a,b) RET_PP(a,b)
99 # define RET_PPP(a,b,c) \
100 R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 2; \
101 JMP_(ENTRY_CODE(Sp[2]));
102 # define RET_NNP(a,b,c) \
103 R1.w = (W_)(a); Sp[-2] = (W_)(b); Sp[-1] = (W_)(c); Sp -= 3; \
104 JMP_(ENTRY_CODE(Sp[3]));
106 # define RET_NNNP(a,b,c,d) \
108 /* Sp[-5] = ARGTAG(1); */ \
110 /* Sp[-3] = ARGTAG(1); */ \
114 JMP_(ENTRY_CODE(Sp[5]));
116 # define RET_NPNP(a,b,c,d) \
119 /* Sp[-3] = ARGTAG(1); */ \
123 JMP_(ENTRY_CODE(Sp[4]));
125 # define RET_NNPNNP(a,b,c,d,e,f) \
129 /* Sp[-3] = ARGTAG(1); */ \
131 /* Sp[-5] = ARGTAG(1); */ \
134 /* Sp[-8] = ARGTAG(1); */ \
136 JMP_(ENTRY_CODE(Sp[8]));
138 #else /* 0 Regs available */
140 #define PUSH_P(o,x) Sp[-o] = (W_)(x)
141 #define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
142 #define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
144 /* Here's how to construct these macros:
146 * N = number of N's in the name;
147 * P = number of P's in the name;
149 * while (nonNull(name)) {
150 * if (nextChar == 'P') {
161 # define RET_P(a) PUSH_P(1,a); PUSHED(1)
162 # define RET_N(a) PUSH_N(2,a); PUSHED(2)
164 # define RET_PP(a,b) PUSH_P(2,a); PUSH_P(1,b); PUSHED(2)
165 # define RET_NN(a,b) PUSH_N(4,a); PUSH_N(2,b); PUSHED(4)
166 # define RET_NP(a,b) PUSH_N(3,a); PUSH_P(1,b); PUSHED(3)
168 # define RET_PPP(a,b,c) PUSH_P(3,a); PUSH_P(2,b); PUSH_P(1,c); PUSHED(3)
169 # define RET_NNP(a,b,c) PUSH_N(6,a); PUSH_N(4,b); PUSH_N(2,c); PUSHED(6)
171 # 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)
172 # 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)
173 # 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)
180 /*-----------------------------------------------------------------------------
183 Basically just new*Array - the others are all inline macros.
185 The size arg is always passed in R1, and the result returned in R1.
187 The slow entry point is for returning from a heap check, the saved
188 size argument must be re-loaded from the stack.
189 -------------------------------------------------------------------------- */
191 /* for objects that are *less* than the size of a word, make sure we
192 * round up to the nearest word for the size of the array.
195 #define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
197 #define newByteArray(ty,scale) \
198 FN_(new##ty##Arrayzh_fast) \
200 W_ stuff_size, size, n; \
203 MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast); \
205 stuff_size = BYTES_TO_STGWORDS(n*scale); \
206 size = sizeofW(StgArrWords)+ stuff_size; \
207 p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
208 TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
209 SET_HDR(p, &ARR_WORDS_info, CCCS); \
210 p->words = stuff_size; \
211 TICK_RET_UNBOXED_TUP(1) \
216 newByteArray(Char, sizeof(C_))
217 newByteArray(Int, sizeof(I_));
218 newByteArray(Word, sizeof(W_));
219 newByteArray(Addr, sizeof(P_));
220 newByteArray(Float, sizeof(StgFloat));
221 newByteArray(Double, sizeof(StgDouble));
222 newByteArray(StablePtr, sizeof(StgStablePtr));
232 MAYBE_GC(R2_PTR,newArrayzh_fast);
234 size = sizeofW(StgMutArrPtrs) + n;
235 arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
236 TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
238 SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
242 for (p = (P_)arr + sizeofW(StgMutArrPtrs);
243 p < (P_)arr + size; p++) {
247 TICK_RET_UNBOXED_TUP(1);
252 FN_(newMutVarzh_fast)
255 /* Args: R1.p = initialisation value */
258 HP_CHK_GEN(sizeofW(StgMutVar), R1_PTR, newMutVarzh_fast,);
259 TICK_ALLOC_PRIM(sizeofW(StgHeader)+1,1, 0); /* hack, dependent on rep. */
260 CCS_ALLOC(CCCS,sizeofW(StgMutVar));
262 mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
263 SET_HDR(mv,&MUT_VAR_info,CCCS);
266 TICK_RET_UNBOXED_TUP(1);
271 /* -----------------------------------------------------------------------------
272 Foreign Object Primitives
274 -------------------------------------------------------------------------- */
277 FN_(makeForeignObjzh_fast)
279 /* R1.p = ptr to foreign object,
281 StgForeignObj *result;
284 HP_CHK_GEN(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
285 TICK_ALLOC_PRIM(sizeofW(StgHeader),
286 sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
287 CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
289 result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
290 SET_HDR(result,&FOREIGN_info,CCCS);
293 /* returns (# s#, ForeignObj# #) */
294 TICK_RET_UNBOXED_TUP(1);
300 /* These two are out-of-line for the benefit of the NCG */
301 FN_(unsafeThawArrayzh_fast)
304 SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
305 recordMutable((StgMutClosure*)R1.cl);
307 TICK_RET_UNBOXED_TUP(1);
312 /* -----------------------------------------------------------------------------
313 Weak Pointer Primitives
314 -------------------------------------------------------------------------- */
327 HP_CHK_GEN(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
328 TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
329 sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
330 CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
332 w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
333 SET_HDR(w, &WEAK_info, CCCS);
338 w->finalizer = R3.cl;
340 w->finalizer = &NO_FINALIZER_closure;
343 w->link = weak_ptr_list;
345 IF_DEBUG(weak, fprintf(stderr,"New weak pointer at %p\n",w));
347 TICK_RET_UNBOXED_TUP(1);
352 FN_(finalizzeWeakzh_fast)
359 TICK_RET_UNBOXED_TUP(0);
360 w = (StgDeadWeak *)R1.p;
363 if (w->header.info == &DEAD_WEAK_info) {
364 RET_NP(0,&NO_FINALIZER_closure);
368 w->header.info = &DEAD_WEAK_info;
369 f = ((StgWeak *)w)->finalizer;
370 w->link = ((StgWeak *)w)->link;
372 /* return the finalizer */
373 if (f == &NO_FINALIZER_closure) {
374 RET_NP(0,&NO_FINALIZER_closure);
383 /* -----------------------------------------------------------------------------
384 Arbitrary-precision Integer operations.
385 -------------------------------------------------------------------------- */
387 FN_(int2Integerzh_fast)
389 /* arguments: R1 = Int# */
391 I_ val, s; /* to avoid aliasing */
392 StgArrWords* p; /* address of array result */
396 HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, int2Integerzh_fast,);
397 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
398 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
400 p = stgCast(StgArrWords*,Hp)-1;
401 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
403 /* mpz_set_si is inlined here, makes things simpler */
407 } else if (val > 0) {
414 /* returns (# size :: Int#,
418 TICK_RET_UNBOXED_TUP(2);
423 FN_(word2Integerzh_fast)
425 /* arguments: R1 = Word# */
427 W_ val; /* to avoid aliasing */
429 StgArrWords* p; /* address of array result */
433 HP_CHK_GEN(sizeofW(StgArrWords)+1, NO_PTRS, word2Integerzh_fast,)
434 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
435 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
437 p = stgCast(StgArrWords*,Hp)-1;
438 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
447 /* returns (# size :: Int#,
451 TICK_RET_UNBOXED_TUP(2);
456 FN_(addr2Integerzh_fast)
462 MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
464 /* args: R1 :: Addr# */
467 /* Perform the operation */
468 if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
471 /* returns (# size :: Int#,
475 TICK_RET_UNBOXED_TUP(2);
476 RET_NP(result._mp_size,
477 result._mp_d - sizeofW(StgArrWords));
482 * 'long long' primops for converting to/from Integers.
485 #ifdef SUPPORT_LONG_LONGS
487 FN_(int64ToIntegerzh_fast)
489 /* arguments: L1 = Int64# */
491 StgInt64 val; /* to avoid aliasing */
493 I_ s, neg, words_needed;
494 StgArrWords* p; /* address of array result */
500 if ( val >= 0x100000000LL || val <= -0x100000000LL ) {
503 /* minimum is one word */
506 HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, int64ToIntegerzh_fast,)
507 TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
508 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
510 p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
511 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
518 hi = (W_)((LW_)val / 0x100000000ULL);
520 if ( words_needed == 2 ) {
524 } else if ( val != 0 ) {
527 } else /* val==0 */ {
530 s = ( neg ? -s : s );
532 /* returns (# size :: Int#,
536 TICK_RET_UNBOXED_TUP(2);
541 FN_(word64ToIntegerzh_fast)
543 /* arguments: L1 = Word64# */
545 StgWord64 val; /* to avoid aliasing */
548 StgArrWords* p; /* address of array result */
552 if ( val >= 0x100000000ULL ) {
557 HP_CHK_GEN(sizeofW(StgArrWords)+words_needed, NO_PTRS, word64ToIntegerzh_fast,)
558 TICK_ALLOC_PRIM(sizeofW(StgArrWords),words_needed,0);
559 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
561 p = stgCast(StgArrWords*,(Hp-words_needed+1))-1;
562 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
564 hi = (W_)((LW_)val / 0x100000000ULL);
565 if ( val >= 0x100000000ULL ) {
569 } else if ( val != 0 ) {
572 } else /* val==0 */ {
576 /* returns (# size :: Int#,
580 TICK_RET_UNBOXED_TUP(2);
586 #endif /* HAVE_LONG_LONG */
588 /* ToDo: this is shockingly inefficient */
590 #define GMP_TAKE2_RET1(name,mp_fun) \
593 MP_INT arg1, arg2, result; \
599 /* call doYouWantToGC() */ \
600 MAYBE_GC(R2_PTR | R4_PTR, name); \
602 d1 = (StgArrWords *)R2.p; \
604 d2 = (StgArrWords *)R4.p; \
607 arg1._mp_alloc = d1->words; \
608 arg1._mp_size = (s1); \
609 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
610 arg2._mp_alloc = d2->words; \
611 arg2._mp_size = (s2); \
612 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
614 STGCALL1(mpz_init,&result); \
616 /* Perform the operation */ \
617 STGCALL3(mp_fun,&result,&arg1,&arg2); \
619 TICK_RET_UNBOXED_TUP(2); \
620 RET_NP(result._mp_size, \
621 result._mp_d-sizeofW(StgArrWords)); \
625 #define GMP_TAKE2_RET2(name,mp_fun) \
628 MP_INT arg1, arg2, result1, result2; \
634 /* call doYouWantToGC() */ \
635 MAYBE_GC(R2_PTR | R4_PTR, name); \
637 d1 = (StgArrWords *)R2.p; \
639 d2 = (StgArrWords *)R4.p; \
642 arg1._mp_alloc = d1->words; \
643 arg1._mp_size = (s1); \
644 arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
645 arg2._mp_alloc = d2->words; \
646 arg2._mp_size = (s2); \
647 arg2._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
649 STGCALL1(mpz_init,&result1); \
650 STGCALL1(mpz_init,&result2); \
652 /* Perform the operation */ \
653 STGCALL4(mp_fun,&result1,&result2,&arg1,&arg2); \
655 TICK_RET_UNBOXED_TUP(4); \
656 RET_NPNP(result1._mp_size, \
657 result1._mp_d-sizeofW(StgArrWords), \
659 result2._mp_d-sizeofW(StgArrWords)); \
663 GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add);
664 GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub);
665 GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul);
666 GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd);
668 GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
669 GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
671 #ifndef FLOATS_AS_DOUBLES
672 FN_(decodeFloatzh_fast)
680 /* arguments: F1 = Float# */
683 HP_CHK_GEN(sizeof(StgArrWords)+1, NO_PTRS, decodeFloatzh_fast,);
684 TICK_ALLOC_PRIM(sizeofW(StgArrWords),1,0);
685 CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
687 /* Be prepared to tell Lennart-coded __decodeFloat */
688 /* where mantissa._mp_d can be put (it does not care about the rest) */
689 p = stgCast(StgArrWords*,Hp)-1;
690 SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
691 mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
693 /* Perform the operation */
694 STGCALL3(__decodeFloat,&mantissa,&exponent,arg);
696 /* returns: (Int# (expn), Int#, ByteArray#) */
697 TICK_RET_UNBOXED_TUP(3);
698 RET_NNP(exponent,mantissa._mp_size,p);
701 #endif /* !FLOATS_AS_DOUBLES */
703 #define DOUBLE_MANTISSA_SIZE (sizeof(StgDouble)/sizeof(W_))
704 #define ARR_SIZE (sizeof(StgArrWords) + DOUBLE_MANTISSA_SIZE)
706 FN_(decodeDoublezh_fast)
713 /* arguments: D1 = Double# */
716 HP_CHK_GEN(ARR_SIZE, NO_PTRS, decodeDoublezh_fast,);
717 TICK_ALLOC_PRIM(sizeof(StgArrWords),DOUBLE_MANTISSA_SIZE,0);
718 CCS_ALLOC(CCCS,ARR_SIZE); /* ccs prof */
720 /* Be prepared to tell Lennart-coded __decodeDouble */
721 /* where mantissa.d can be put (it does not care about the rest) */
722 p = stgCast(StgArrWords*,Hp-ARR_SIZE+1);
723 SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
724 mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
726 /* Perform the operation */
727 STGCALL3(__decodeDouble,&mantissa,&exponent,arg);
729 /* returns: (Int# (expn), Int#, ByteArray#) */
730 TICK_RET_UNBOXED_TUP(3);
731 RET_NNP(exponent,mantissa._mp_size,p);
735 /* -----------------------------------------------------------------------------
736 * Concurrency primitives
737 * -------------------------------------------------------------------------- */
742 /* args: R1 = closure to spark */
744 if (closure_SHOULD_SPARK(stgCast(StgClosure*,R1.p))) {
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 */
756 JMP_(ENTRY_CODE(Sp[0]));
760 FN_(killThreadzh_fast)
763 /* args: R1.p = TSO to kill */
765 /* The thread is dead, but the TSO sticks around for a while. That's why
766 * we don't have to explicitly remove it from any queues it might be on.
768 STGCALL1(deleteThread, (StgTSO *)R1.p);
770 /* We might have killed ourselves. In which case, better return to the
773 if ((StgTSO *)R1.p == CurrentTSO) {
774 JMP_(stg_stop_thread_entry); /* leave semi-gracefully */
777 JMP_(ENTRY_CODE(Sp[0]));
788 HP_CHK_GEN(sizeofW(StgMVar), NO_PTRS, newMVarzh_fast,);
789 TICK_ALLOC_PRIM(sizeofW(StgMutVar)-1, // consider head,tail,link as admin wds
791 CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
793 mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
794 SET_INFO(mvar,&EMPTY_MVAR_info);
795 mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
796 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
798 TICK_RET_UNBOXED_TUP(1);
809 /* args: R1 = MVar closure */
811 mvar = (StgMVar *)R1.p;
813 /* If the MVar is empty, put ourselves on its blocking queue,
814 * and wait until we're woken up.
816 if (GET_INFO(mvar) != &FULL_MVAR_info) {
817 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
818 mvar->head = CurrentTSO;
820 mvar->tail->link = CurrentTSO;
822 CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
823 mvar->tail = CurrentTSO;
825 BLOCK(R1_PTR, takeMVarzh_fast);
828 SET_INFO(mvar,&EMPTY_MVAR_info);
830 mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
832 TICK_RET_UNBOXED_TUP(1);
843 /* args: R1 = MVar, R2 = value */
845 mvar = (StgMVar *)R1.p;
846 if (GET_INFO(mvar) == &FULL_MVAR_info) {
848 fprintf(stderr, "putMVar#: MVar already full.\n");
849 stg_exit(EXIT_FAILURE);
852 SET_INFO(mvar,&FULL_MVAR_info);
855 /* wake up the first thread on the queue,
856 * it will continue with the takeMVar operation and mark the MVar
860 if (tso != (StgTSO *)&END_TSO_QUEUE_closure) {
861 PUSH_ON_RUN_QUEUE(tso);
862 mvar->head = tso->link;
863 tso->link = (StgTSO *)&END_TSO_QUEUE_closure;
864 if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
865 mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
869 /* ToDo: yield here for better communication performance? */
870 JMP_(ENTRY_CODE(Sp[0]));
874 /* -----------------------------------------------------------------------------
875 Stable pointer primitives
876 ------------------------------------------------------------------------- */
878 FN_(makeStableNamezh_fast)
881 StgStableName *sn_obj;
884 HP_CHK_GEN(sizeofW(StgStableName), R1_PTR, makeStableNamezh_fast,);
885 TICK_ALLOC_PRIM(sizeofW(StgHeader),
886 sizeofW(StgStableName)-sizeofW(StgHeader), 0);
887 CCS_ALLOC(CCCS,sizeofW(StgStableName)); /* ccs prof */
889 index = RET_STGCALL1(StgWord,lookupStableName,R1.p);
891 /* Is there already a StableName for this heap object? */
892 if (stable_ptr_table[index].sn_obj == NULL) {
893 sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
894 sn_obj->header.info = &STABLE_NAME_info;
896 stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
898 (StgClosure *)sn_obj = stable_ptr_table[index].sn_obj;
901 TICK_RET_UNBOXED_TUP(1);
905 #endif /* COMPILER */