/* -----------------------------------------------------------------------------
- * $Id: PrimOps.hc,v 1.38 2000/01/13 12:40:15 simonmar Exp $
+ * $Id: PrimOps.hc,v 1.66 2000/12/20 15:17:55 rrt Exp $
*
- * (c) The GHC Team, 1998-1999
+ * (c) The GHC Team, 1998-2000
*
* Primitive functions / data
*
#include "StablePriv.h"
#include "HeapStackCheck.h"
#include "StgRun.h"
+#include "Itimer.h"
+#include "Prelude.h"
/* ** temporary **
#else /* 0 Regs available */
#define PUSH_P(o,x) Sp[-o] = (W_)(x)
-#define PUSH_N(o,x) Sp[1-o] = (W_)(x); /* Sp[-o] = ARGTAG(1) */
+
+#ifdef DEBUG
+#define PUSH_N(o,x) Sp[1-o] = (W_)(x); Sp[-o] = ARG_TAG(1);
+#else
+#define PUSH_N(o,x) Sp[1-o] = (W_)(x);
+#endif
+
#define PUSHED(m) Sp -= (m); JMP_(ENTRY_CODE(Sp[m]));
/* Here's how to construct these macros:
#define BYTES_TO_STGWORDS(n) ((n) + sizeof(W_) - 1)/sizeof(W_)
-#define newByteArray(ty,scale) \
- FN_(new##ty##Arrayzh_fast) \
+FN_(newByteArrayzh_fast) \
{ \
- W_ stuff_size, size, n; \
+ W_ size, stuff_size, n; \
StgArrWords* p; \
FB_ \
- MAYBE_GC(NO_PTRS,new##ty##Arrayzh_fast); \
+ MAYBE_GC(NO_PTRS,newByteArrayzh_fast); \
n = R1.w; \
- stuff_size = BYTES_TO_STGWORDS(n*scale); \
+ stuff_size = BYTES_TO_STGWORDS(n); \
size = sizeofW(StgArrWords)+ stuff_size; \
p = (StgArrWords *)RET_STGCALL1(P_,allocate,size); \
TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \
- SET_HDR(p, &ARR_WORDS_info, CCCS); \
+ SET_HDR(p, &stg_ARR_WORDS_info, CCCS); \
p->words = stuff_size; \
TICK_RET_UNBOXED_TUP(1) \
RET_P(p); \
FE_ \
}
-newByteArray(Char, sizeof(C_))
-newByteArray(Int, sizeof(I_));
-newByteArray(Word, sizeof(W_));
-newByteArray(Addr, sizeof(P_));
-newByteArray(Float, sizeof(StgFloat));
-newByteArray(Double, sizeof(StgDouble));
-newByteArray(StablePtr, sizeof(StgStablePtr));
-
FN_(newArrayzh_fast)
{
W_ size, n, init;
arr = (StgMutArrPtrs *)RET_STGCALL1(P_, allocate, size);
TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
- SET_HDR(arr,&MUT_ARR_PTRS_info,CCCS);
+ SET_HDR(arr,&stg_MUT_ARR_PTRS_info,CCCS);
arr->ptrs = n;
init = R2.w;
CCS_ALLOC(CCCS,sizeofW(StgMutVar));
mv = (StgMutVar *)(Hp-sizeofW(StgMutVar)+1);
- SET_HDR(mv,&MUT_VAR_info,CCCS);
+ SET_HDR(mv,&stg_MUT_VAR_info,CCCS);
mv->var = R1.cl;
TICK_RET_UNBOXED_TUP(1);
-------------------------------------------------------------------------- */
#ifndef PAR
-FN_(makeForeignObjzh_fast)
+FN_(mkForeignObjzh_fast)
{
/* R1.p = ptr to foreign object,
*/
StgForeignObj *result;
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, makeForeignObjzh_fast,);
+ HP_CHK_GEN_TICKY(sizeofW(StgForeignObj), NO_PTRS, mkForeignObjzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader),
sizeofW(StgForeignObj)-sizeofW(StgHeader), 0);
CCS_ALLOC(CCCS,sizeofW(StgForeignObj)); /* ccs prof */
result = (StgForeignObj *) (Hp + 1 - sizeofW(StgForeignObj));
- SET_HDR(result,&FOREIGN_info,CCCS);
+ SET_HDR(result,&stg_FOREIGN_info,CCCS);
result->data = R1.p;
/* returns (# s#, ForeignObj# #) */
FN_(unsafeThawArrayzh_fast)
{
FB_
- SET_INFO((StgClosure *)R1.cl,&MUT_ARR_PTRS_info);
+ SET_INFO((StgClosure *)R1.cl,&stg_MUT_ARR_PTRS_info);
recordMutable((StgMutClosure*)R1.cl);
TICK_RET_UNBOXED_TUP(1);
{
/* R1.p = key
R2.p = value
- R3.p = finalizer
+ R3.p = finalizer (or NULL)
*/
StgWeak *w;
FB_
- HP_CHK_GEN_TICKY(sizeofW(StgWeak), R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
+ if (R3.cl == NULL) {
+ R3.cl = &stg_NO_FINALIZER_closure;
+ }
+
+ HP_CHK_GEN_TICKY(sizeofW(StgWeak),R1_PTR|R2_PTR|R3_PTR, mkWeakzh_fast,);
TICK_ALLOC_PRIM(sizeofW(StgHeader)+1, // +1 is for the link field
sizeofW(StgWeak)-sizeofW(StgHeader)-1, 0);
CCS_ALLOC(CCCS,sizeofW(StgWeak)); /* ccs prof */
w = (StgWeak *) (Hp + 1 - sizeofW(StgWeak));
- SET_HDR(w, &WEAK_info, CCCS);
+ SET_HDR(w, &stg_WEAK_info, CCCS);
w->key = R1.cl;
w->value = R2.cl;
- if (R3.cl) {
- w->finalizer = R3.cl;
- } else {
- w->finalizer = &NO_FINALIZER_closure;
- }
+ w->finalizer = R3.cl;
w->link = weak_ptr_list;
weak_ptr_list = w;
w = (StgDeadWeak *)R1.p;
/* already dead? */
- if (w->header.info == &DEAD_WEAK_info) {
- RET_NP(0,&NO_FINALIZER_closure);
+ if (w->header.info == &stg_DEAD_WEAK_info) {
+ RET_NP(0,&stg_NO_FINALIZER_closure);
}
/* kill it */
- w->header.info = &DEAD_WEAK_info;
+ w->header.info = &stg_DEAD_WEAK_info;
f = ((StgWeak *)w)->finalizer;
w->link = ((StgWeak *)w)->link;
/* return the finalizer */
- if (f == &NO_FINALIZER_closure) {
- RET_NP(0,&NO_FINALIZER_closure);
+ if (f == &stg_NO_FINALIZER_closure) {
+ RET_NP(0,&stg_NO_FINALIZER_closure);
} else {
RET_NP(1,f);
}
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+ SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
/* mpz_set_si is inlined here, makes things simpler */
if (val < 0) {
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+1); /* ccs prof */
p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, 1);
+ SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, 1);
if (val != 0) {
s = 1;
FE_
}
-FN_(addr2Integerzh_fast)
-{
- MP_INT result;
- char *str;
- FB_
-
- MAYBE_GC(NO_PTRS,addr2Integerzh_fast);
-
- /* args: R1 :: Addr# */
- str = R1.a;
-
- /* Perform the operation */
- if (RET_STGCALL3(int, mpz_init_set_str,&result,(str),/*base*/10))
- abort();
-
- /* returns (# size :: Int#,
- data :: ByteArray#
- #)
- */
- TICK_RET_UNBOXED_TUP(2);
- RET_NP(result._mp_size,
- result._mp_d - sizeofW(StgArrWords));
- FE_
-}
/*
* 'long long' primops for converting to/from Integers.
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
p = (StgArrWords *)(Hp-words_needed+1) - 1;
- SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+ SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
if ( val < 0LL ) {
neg = 1;
CCS_ALLOC(CCCS,sizeofW(StgArrWords)+words_needed); /* ccs prof */
p = (StgArrWords *)(Hp-words_needed+1) - 1;
- SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, words_needed);
+ SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, words_needed);
hi = (W_)((LW_)val / 0x100000000ULL);
if ( val >= 0x100000000ULL ) {
FN_(name) \
{ \
MP_INT arg1, arg2, result; \
- I_ s1, s2; \
+ I_ s1, s2; \
StgArrWords* d1; \
StgArrWords* d2; \
FB_ \
FE_ \
}
+#define GMP_TAKE1_RET1(name,mp_fun) \
+FN_(name) \
+{ \
+ MP_INT arg1, result; \
+ I_ s1; \
+ StgArrWords* d1; \
+ FB_ \
+ \
+ /* call doYouWantToGC() */ \
+ MAYBE_GC(R2_PTR, name); \
+ \
+ d1 = (StgArrWords *)R2.p; \
+ s1 = R1.i; \
+ \
+ arg1._mp_alloc = d1->words; \
+ arg1._mp_size = (s1); \
+ arg1._mp_d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
+ \
+ STGCALL1(mpz_init,&result); \
+ \
+ /* Perform the operation */ \
+ STGCALL2(mp_fun,&result,&arg1); \
+ \
+ TICK_RET_UNBOXED_TUP(2); \
+ RET_NP(result._mp_size, \
+ result._mp_d-sizeofW(StgArrWords)); \
+ FE_ \
+}
+
#define GMP_TAKE2_RET2(name,mp_fun) \
FN_(name) \
{ \
MP_INT arg1, arg2, result1, result2; \
- I_ s1, s2; \
+ I_ s1, s2; \
StgArrWords* d1; \
StgArrWords* d2; \
FB_ \
GMP_TAKE2_RET1(quotIntegerzh_fast, mpz_tdiv_q);
GMP_TAKE2_RET1(remIntegerzh_fast, mpz_tdiv_r);
GMP_TAKE2_RET1(divExactIntegerzh_fast, mpz_divexact);
+GMP_TAKE2_RET1(andIntegerzh_fast, mpz_and);
+GMP_TAKE2_RET1(orIntegerzh_fast, mpz_ior);
+GMP_TAKE2_RET1(xorIntegerzh_fast, mpz_xor);
+GMP_TAKE1_RET1(complementIntegerzh_fast, mpz_com);
GMP_TAKE2_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr);
GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr);
-#ifndef FLOATS_AS_DOUBLES
FN_(decodeFloatzh_fast)
{
MP_INT mantissa;
/* Be prepared to tell Lennart-coded __decodeFloat */
/* where mantissa._mp_d can be put (it does not care about the rest) */
p = (StgArrWords *)Hp - 1;
- SET_ARR_HDR(p,&ARR_WORDS_info,CCCS,1)
+ SET_ARR_HDR(p,&stg_ARR_WORDS_info,CCCS,1)
mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
/* Perform the operation */
RET_NNP(exponent,mantissa._mp_size,p);
FE_
}
-#endif /* !FLOATS_AS_DOUBLES */
#define DOUBLE_MANTISSA_SIZE (sizeofW(StgDouble))
#define ARR_SIZE (sizeofW(StgArrWords) + DOUBLE_MANTISSA_SIZE)
/* Be prepared to tell Lennart-coded __decodeDouble */
/* where mantissa.d can be put (it does not care about the rest) */
p = (StgArrWords *)(Hp-ARR_SIZE+1);
- SET_ARR_HDR(p, &ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
+ SET_ARR_HDR(p, &stg_ARR_WORDS_info, CCCS, DOUBLE_MANTISSA_SIZE);
mantissa._mp_d = (void *)BYTE_ARR_CTS(p);
/* Perform the operation */
CCS_ALLOC(CCCS,sizeofW(StgMVar)); /* ccs prof */
mvar = (StgMVar *) (Hp - sizeofW(StgMVar) + 1);
- SET_HDR(mvar,&EMPTY_MVAR_info,CCCS);
- mvar->head = mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
- mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+ SET_HDR(mvar,&stg_EMPTY_MVAR_info,CCCS);
+ mvar->head = mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
+ mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
TICK_RET_UNBOXED_TUP(1);
RET_P(mvar);
/* If the MVar is empty, put ourselves on its blocking queue,
* and wait until we're woken up.
*/
- if (info == &EMPTY_MVAR_info) {
- if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
+ if (info == &stg_EMPTY_MVAR_info) {
+ if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
mvar->head = CurrentTSO;
} else {
mvar->tail->link = CurrentTSO;
}
- CurrentTSO->link = (StgTSO *)&END_TSO_QUEUE_closure;
+ CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure;
CurrentTSO->why_blocked = BlockedOnMVar;
CurrentTSO->block_info.closure = (StgClosure *)mvar;
mvar->tail = CurrentTSO;
#ifdef SMP
/* unlock the MVar */
- mvar->header.info = &EMPTY_MVAR_info;
+ mvar->header.info = &stg_EMPTY_MVAR_info;
#endif
BLOCK(R1_PTR, takeMVarzh_fast);
}
val = mvar->value;
- mvar->value = (StgClosure *)&END_TSO_QUEUE_closure;
+ mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
/* do this last... we might have locked the MVar in the SMP case,
* and writing the info pointer will unlock it.
*/
- SET_INFO(mvar,&EMPTY_MVAR_info);
+ SET_INFO(mvar,&stg_EMPTY_MVAR_info);
TICK_RET_UNBOXED_TUP(1);
RET_P(val);
FE_
}
+FN_(tryTakeMVarzh_fast)
+{
+ StgMVar *mvar;
+ StgClosure *val;
+ const StgInfoTable *info;
+
+ FB_
+ /* args: R1 = MVar closure */
+
+ mvar = (StgMVar *)R1.p;
+
+#ifdef SMP
+ info = LOCK_CLOSURE(mvar);
+#else
+ info = GET_INFO(mvar);
+#endif
+
+ if (info == &stg_EMPTY_MVAR_info) {
+
+#ifdef SMP
+ /* unlock the MVar */
+ mvar->header.info = &stg_EMPTY_MVAR_info;
+#endif
+
+ /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */
+ RET_NP(0, &stg_NO_FINALIZER_closure);
+ }
+
+ val = mvar->value;
+ mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure;
+
+ /* do this last... we might have locked the MVar in the SMP case,
+ * and writing the info pointer will unlock it.
+ */
+ SET_INFO(mvar,&stg_EMPTY_MVAR_info);
+
+ TICK_RET_UNBOXED_TUP(1);
+ RET_NP(1,val);
+ FE_
+}
+
FN_(putMVarzh_fast)
{
StgMVar *mvar;
info = GET_INFO(mvar);
#endif
- if (info == &FULL_MVAR_info) {
- barf("putMVar#: MVar already full");
+ if (info == &stg_FULL_MVAR_info) {
+#ifdef INTERPRETER
+ fprintf(stderr, "fatal: put on a full MVar in Hugs; aborting\n" );
+ exit(1);
+#else
+ R1.cl = (StgClosure *)PutFullMVar_closure;
+ JMP_(raisezh_fast);
+#endif
}
mvar->value = R2.cl;
/* wake up the first thread on the queue, it will continue with the
* takeMVar operation and mark the MVar empty again.
*/
- if (mvar->head != (StgTSO *)&END_TSO_QUEUE_closure) {
+ if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) {
ASSERT(mvar->head->why_blocked == BlockedOnMVar);
+#if defined(GRAN)
+ mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
+#elif defined(PAR)
+ // ToDo: check 2nd arg (mvar) is right
+ mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar);
+#else
mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head);
- if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) {
- mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure;
+#endif
+ if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) {
+ mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure;
}
}
/* unlocks the MVar in the SMP case */
- SET_INFO(mvar,&FULL_MVAR_info);
+ SET_INFO(mvar,&stg_FULL_MVAR_info);
/* ToDo: yield here for better communication performance? */
JMP_(ENTRY_CODE(Sp[0]));
/* Is there already a StableName for this heap object? */
if (stable_ptr_table[index].sn_obj == NULL) {
sn_obj = (StgStableName *) (Hp - sizeofW(StgStableName) + 1);
- sn_obj->header.info = &STABLE_NAME_info;
+ sn_obj->header.info = &stg_STABLE_NAME_info;
sn_obj->sn = index;
stable_ptr_table[index].sn_obj = (StgClosure *)sn_obj;
} else {
}
/* -----------------------------------------------------------------------------
+ Bytecode object primitives
+ ------------------------------------------------------------------------- */
+
+#ifdef GHCI
+FN_(newBCOzh_fast)
+{
+ /* R1.p = instrs
+ R2.p = literals
+ R3.p = ptrs
+ R4.p = itbls
+ */
+ StgBCO *bco;
+ FB_
+
+ HP_CHK_GEN_TICKY(sizeofW(StgBCO),R1_PTR|R2_PTR|R3_PTR|R4_PTR, newBCOzh_fast,);
+ TICK_ALLOC_PRIM(sizeofW(StgHeader), sizeofW(StgBCO)-sizeofW(StgHeader), 0);
+ CCS_ALLOC(CCCS,sizeofW(StgBCO)); /* ccs prof */
+ bco = (StgBCO *) (Hp + 1 - sizeofW(StgBCO));
+ SET_HDR(bco, &stg_BCO_info, CCCS);
+
+ bco->instrs = (StgArrWords*)R1.cl;
+ bco->literals = (StgArrWords*)R2.cl;
+ bco->ptrs = (StgMutArrPtrs*)R3.cl;
+ bco->itbls = (StgArrWords*)R4.cl;
+
+ TICK_RET_UNBOXED_TUP(1);
+ RET_P(bco);
+ FE_
+}
+#endif
+
+/* -----------------------------------------------------------------------------
Thread I/O blocking primitives
-------------------------------------------------------------------------- */
FN_(delayzh_fast)
{
+ StgTSO *t, *prev;
+ nat target;
FB_
/* args: R1.i */
ASSERT(CurrentTSO->why_blocked == NotBlocked);
ACQUIRE_LOCK(&sched_mutex);
- /* Add on ticks_since_select, since these will be subtracted at
- * the next awaitEvent call.
- */
- CurrentTSO->block_info.delay = R1.i + ticks_since_select;
+ target = (R1.i / (TICK_MILLISECS*1000)) + timestamp + ticks_since_timestamp;
+ CurrentTSO->block_info.target = target;
- APPEND_TO_BLOCKED_QUEUE(CurrentTSO);
+ /* Insert the new thread in the sleeping queue. */
+ prev = NULL;
+ t = sleeping_queue;
+ while (t != END_TSO_QUEUE && t->block_info.target < target) {
+ prev = t;
+ t = t->link;
+ }
+
+ CurrentTSO->link = t;
+ if (prev == NULL) {
+ sleeping_queue = CurrentTSO;
+ } else {
+ prev->link = CurrentTSO;
+ }
RELEASE_LOCK(&sched_mutex);
JMP_(stg_block_noregs);
FE_
}
-
projects / ghc-hetmet.git / blobdiff