X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FPrimOps.hc;h=015e34a228b267e8e1555c5645dbbf8084c63ef0;hb=b86f4b95cb51d69a2537217132f675afa1e9519c;hp=0a18aaf91b66542e7faa37d2700de193b514c89f;hpb=5c67176de89fee19a02056216a7c58579e765148;p=ghc-hetmet.git diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 0a18aaf..015e34a 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,7 +1,7 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.31 1999/10/13 16:39:23 simonmar Exp $ + * $Id: PrimOps.hc,v 1.53 2000/08/07 23:37:23 qrczak Exp $ * - * (c) The GHC Team, 1998-1999 + * (c) The GHC Team, 1998-2000 * * Primitive functions / data * @@ -9,8 +9,6 @@ #include "Rts.h" -#ifdef COMPILER - #include "RtsFlags.h" #include "StgStartup.h" #include "SchedAPI.h" @@ -21,6 +19,8 @@ #include "StablePriv.h" #include "HeapStackCheck.h" #include "StgRun.h" +#include "Itimer.h" +#include "Prelude.h" /* ** temporary ** @@ -55,7 +55,7 @@ W_ GHC_ZCCReturnable_static_info[0]; */ /*------ All Regs available */ -#ifdef REG_R8 +#if defined(REG_R8) # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0])); # define RET_N(a) RET_P(a) @@ -80,15 +80,60 @@ W_ GHC_ZCCReturnable_static_info[0]; R4.w = (W_)(d); R5.w = (W_)(e); R6.w = (W_)(f); \ JMP_(ENTRY_CODE(Sp[0])); -#else - -#if defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \ - defined(REG_R4) || defined(REG_R3) || defined(REG_R2) +#elif defined(REG_R7) || defined(REG_R6) || defined(REG_R5) || \ + defined(REG_R4) || defined(REG_R3) # error RET_n macros not defined for this setup. -#else + +/*------ 2 Registers available */ +#elif defined(REG_R2) + +# define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0])); +# define RET_N(a) RET_P(a) + +# define RET_PP(a,b) R1.w = (W_)(a); R2.w = (W_)(b); \ + JMP_(ENTRY_CODE(Sp[0])); +# define RET_NN(a,b) RET_PP(a,b) +# define RET_NP(a,b) RET_PP(a,b) + +# define RET_PPP(a,b,c) \ + R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \ + JMP_(ENTRY_CODE(Sp[1])); +# define RET_NNP(a,b,c) \ + R1.w = (W_)(a); R2.w = (W_)(b); Sp[-1] = (W_)(c); Sp -= 1; \ + JMP_(ENTRY_CODE(Sp[1])); + +# define RET_NNNP(a,b,c,d) \ + R1.w = (W_)(a); \ + R2.w = (W_)(b); \ + /* Sp[-3] = ARGTAG(1); */ \ + Sp[-2] = (W_)(c); \ + Sp[-1] = (W_)(d); \ + Sp -= 3; \ + JMP_(ENTRY_CODE(Sp[3])); + +# define RET_NPNP(a,b,c,d) \ + R1.w = (W_)(a); \ + R2.w = (W_)(b); \ + /* Sp[-3] = ARGTAG(1); */ \ + Sp[-2] = (W_)(c); \ + Sp[-1] = (W_)(d); \ + Sp -= 3; \ + JMP_(ENTRY_CODE(Sp[3])); + +# define RET_NNPNNP(a,b,c,d,e,f) \ + R1.w = (W_)(a); \ + R2.w = (W_)(b); \ + Sp[-6] = (W_)(c); \ + /* Sp[-5] = ARGTAG(1); */ \ + Sp[-4] = (W_)(d); \ + /* Sp[-3] = ARGTAG(1); */ \ + Sp[-2] = (W_)(e); \ + Sp[-1] = (W_)(f); \ + Sp -= 6; \ + JMP_(ENTRY_CODE(Sp[6])); /*------ 1 Register available */ -#ifdef REG_R1 +#elif defined(REG_R1) # define RET_P(a) R1.w = (W_)(a); JMP_(ENTRY_CODE(Sp[0])); # define RET_N(a) RET_P(a) @@ -140,7 +185,13 @@ W_ GHC_ZCCReturnable_static_info[0]; #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: @@ -176,9 +227,6 @@ W_ GHC_ZCCReturnable_static_info[0]; #endif -#endif -#endif - /*----------------------------------------------------------------------------- Array Primitives @@ -215,13 +263,14 @@ W_ GHC_ZCCReturnable_static_info[0]; 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)); +newByteArray(Char, 1) +/* Char arrays really contain only 8-bit bytes for compatibility. */ +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) { @@ -276,14 +325,14 @@ FN_(newMutVarzh_fast) -------------------------------------------------------------------------- */ #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 */ @@ -321,12 +370,16 @@ FN_(mkWeakzh_fast) { /* 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 = &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 */ @@ -336,11 +389,7 @@ FN_(mkWeakzh_fast) 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; @@ -593,7 +642,7 @@ FN_(word64ToIntegerzh_fast) FN_(name) \ { \ MP_INT arg1, arg2, result; \ - I_ s1, s2; \ + I_ s1, s2; \ StgArrWords* d1; \ StgArrWords* d2; \ FB_ \ @@ -628,7 +677,7 @@ FN_(name) \ FN_(name) \ { \ MP_INT arg1, arg2, result1, result2; \ - I_ s1, s2; \ + I_ s1, s2; \ StgArrWords* d1; \ StgArrWords* d2; \ FB_ \ @@ -662,10 +711,13 @@ FN_(name) \ FE_ \ } -GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add); -GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub); -GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul); -GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd); +GMP_TAKE2_RET1(plusIntegerzh_fast, mpz_add); +GMP_TAKE2_RET1(minusIntegerzh_fast, mpz_sub); +GMP_TAKE2_RET1(timesIntegerzh_fast, mpz_mul); +GMP_TAKE2_RET1(gcdIntegerzh_fast, mpz_gcd); +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_RET2(quotRemIntegerzh_fast, mpz_tdiv_qr); GMP_TAKE2_RET2(divModIntegerzh_fast, mpz_fdiv_qr); @@ -748,6 +800,7 @@ FN_(forkzh_fast) /* create it right now, return ThreadID in R1 */ R1.t = RET_STGCALL2(StgTSO *, createIOThread, RtsFlags.GcFlags.initialStkSize, R1.cl); + STGCALL1(scheduleThread, R1.t); /* switch at the earliest opportunity */ context_switch = 1; @@ -763,43 +816,6 @@ FN_(yieldzh_fast) FE_ } -FN_(killThreadzh_fast) -{ - FB_ - /* args: R1.p = TSO to kill, R2.p = Exception */ - - /* The thread is dead, but the TSO sticks around for a while. That's why - * we don't have to explicitly remove it from any queues it might be on. - */ - - /* We might have killed ourselves. In which case, better be *very* - * careful. If the exception killed us, then return to the scheduler. - * If the exception went to a catch frame, we'll just continue from - * the handler. - */ - if (R1.t == CurrentTSO) { - SaveThreadState(); /* inline! */ - STGCALL2(raiseAsync, R1.t, R2.cl); - if (CurrentTSO->whatNext == ThreadKilled) { - R1.w = ThreadYielding; - JMP_(StgReturn); - } - LoadThreadState(); - if (CurrentTSO->whatNext == ThreadEnterGHC) { - R1.w = Sp[0]; - Sp++; - JMP_(GET_ENTRY(R1.cl)); - } else { - barf("killThreadzh_fast"); - } - } else { - STGCALL2(raiseAsync, R1.t, R2.cl); - } - - JMP_(ENTRY_CODE(Sp[0])); - FE_ -} - FN_(newMVarzh_fast) { StgMVar *mvar; @@ -826,16 +842,23 @@ FN_(takeMVarzh_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 the MVar is empty, put ourselves on its blocking queue, * and wait until we're woken up. */ - if (GET_INFO(mvar) != &FULL_MVAR_info) { + if (info == &EMPTY_MVAR_info) { if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) { mvar->head = CurrentTSO; } else { @@ -846,32 +869,93 @@ FN_(takeMVarzh_fast) CurrentTSO->block_info.closure = (StgClosure *)mvar; mvar->tail = CurrentTSO; +#ifdef SMP + /* unlock the MVar */ + mvar->header.info = &EMPTY_MVAR_info; +#endif BLOCK(R1_PTR, takeMVarzh_fast); } - SET_INFO(mvar,&EMPTY_MVAR_info); val = mvar->value; mvar->value = (StgClosure *)&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); + 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 == &EMPTY_MVAR_info) { + +#ifdef SMP + /* unlock the MVar */ + mvar->header.info = &EMPTY_MVAR_info; +#endif + + /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */ + RET_NP(0, &NO_FINALIZER_closure); + } + + val = mvar->value; + mvar->value = (StgClosure *)&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); + + TICK_RET_UNBOXED_TUP(1); + RET_NP(1,val); + FE_ +} + FN_(putMVarzh_fast) { StgMVar *mvar; + const StgInfoTable *info; FB_ /* args: R1 = MVar, R2 = value */ mvar = (StgMVar *)R1.p; - if (GET_INFO(mvar) == &FULL_MVAR_info) { - fprintf(stderr, "putMVar#: MVar already full.\n"); - stg_exit(EXIT_FAILURE); + +#ifdef SMP + info = LOCK_CLOSURE(mvar); +#else + info = GET_INFO(mvar); +#endif + + if (info == &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 } - SET_INFO(mvar,&FULL_MVAR_info); mvar->value = R2.cl; /* wake up the first thread on the queue, it will continue with the @@ -879,12 +963,22 @@ FN_(putMVarzh_fast) */ if (mvar->head != (StgTSO *)&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); +#endif if (mvar->head == (StgTSO *)&END_TSO_QUEUE_closure) { mvar->tail = (StgTSO *)&END_TSO_QUEUE_closure; } } + /* unlocks the MVar in the SMP case */ + SET_INFO(mvar,&FULL_MVAR_info); + /* ToDo: yield here for better communication performance? */ JMP_(ENTRY_CODE(Sp[0])); FE_ @@ -932,7 +1026,9 @@ FN_(waitReadzh_fast) ASSERT(CurrentTSO->why_blocked == NotBlocked); CurrentTSO->why_blocked = BlockedOnRead; CurrentTSO->block_info.fd = R1.i; - PUSH_ON_BLOCKED_QUEUE(CurrentTSO); + ACQUIRE_LOCK(&sched_mutex); + APPEND_TO_BLOCKED_QUEUE(CurrentTSO); + RELEASE_LOCK(&sched_mutex); JMP_(stg_block_noregs); FE_ } @@ -944,7 +1040,9 @@ FN_(waitWritezh_fast) ASSERT(CurrentTSO->why_blocked == NotBlocked); CurrentTSO->why_blocked = BlockedOnWrite; CurrentTSO->block_info.fd = R1.i; - PUSH_ON_BLOCKED_QUEUE(CurrentTSO); + ACQUIRE_LOCK(&sched_mutex); + APPEND_TO_BLOCKED_QUEUE(CurrentTSO); + RELEASE_LOCK(&sched_mutex); JMP_(stg_block_noregs); FE_ } @@ -956,15 +1054,22 @@ FN_(delayzh_fast) ASSERT(CurrentTSO->why_blocked == NotBlocked); CurrentTSO->why_blocked = BlockedOnDelay; + ACQUIRE_LOCK(&sched_mutex); + /* Add on ticks_since_select, since these will be subtracted at * the next awaitEvent call. */ +#if defined(HAVE_SETITIMER) || defined(mingw32_TARGET_OS) CurrentTSO->block_info.delay = R1.i + ticks_since_select; +#else + CurrentTSO->block_info.target = R1.i + getourtimeofday(); +#endif + + APPEND_TO_BLOCKED_QUEUE(CurrentTSO); - PUSH_ON_BLOCKED_QUEUE(CurrentTSO); + RELEASE_LOCK(&sched_mutex); JMP_(stg_block_noregs); FE_ } -#endif /* COMPILER */