X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fincludes%2FPrimOps.h;h=4a0f952cd54878fa06acd4ad887e27327b5b7a14;hb=e87d56ce33f663da1c445f37e95c40d814caa384;hp=ba62f8becb56d43a7285cdf87ba99bb3d5bee8f9;hpb=68d47df35cbf143ec2f458e066f9970ecccebe7d;p=ghc-hetmet.git diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index ba62f8b..4a0f952 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.26 1999/04/27 12:32:15 simonm Exp $ + * $Id: PrimOps.h,v 1.45 2000/01/18 12:37:33 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -127,12 +127,12 @@ I_ stg_div (I_ a, I_ b); #define mulIntCzh(r,c,a,b) \ { \ - __asm__("xor %1,%1\n\t \ + __asm__("xorl %1,%1\n\t \ imull %2,%3\n\t \ jno 1f\n\t \ movl $1,%1\n\t \ 1:" \ - : "=r" (r), "=r" (c) : "r" (a), "0" (b)); \ + : "=r" (r), "=&r" (c) : "r" (a), "0" (b)); \ } #elif SIZEOF_VOID_P == 4 @@ -195,15 +195,21 @@ typedef union { #define xorzh(r,a,b) r=(a)^(b) #define notzh(r,a) r=~(a) -#define shiftLzh(r,a,b) r=(a)<<(b) -#define shiftRLzh(r,a,b) r=(a)>>(b) -#define iShiftLzh(r,a,b) r=(a)<<(b) +/* The extra tests below properly define the behaviour when shifting + * by offsets larger than the width of the value being shifted. Doing + * so is undefined in C (and in fact gives different answers depending + * on whether the operation is constant folded or not with gcc on x86!) + */ + +#define shiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b) +#define shiftRLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)>>(b) +#define iShiftLzh(r,a,b) r=((b) >= BITS_IN(W_)) ? 0 : (a)<<(b) /* Right shifting of signed quantities is not portable in C, so the behaviour you'll get from using these primops depends on the whatever your C compiler is doing. ToDo: fix/document. -- sof 8/98 */ -#define iShiftRAzh(r,a,b) r=(a)>>(b) -#define iShiftRLzh(r,a,b) r=(a)>>(b) +#define iShiftRAzh(r,a,b) r=((b) >= BITS_IN(I_)) ? (((a) < 0) ? -1 : 0) : (a)>>(b) +#define iShiftRLzh(r,a,b) r=((b) >= BITS_IN(I_)) ? 0 : ((W_)(a))>>(b) #define int2Wordzh(r,a) r=(W_)(a) #define word2Intzh(r,a) r=(I_)(a) @@ -303,26 +309,26 @@ typedef union { /* We can do integer2Int and cmpInteger inline, since they don't need * to allocate any memory. + * + * integer2Int# is now modular. */ -#define integer2Intzh(r, sa,da) \ -{ MP_INT arg; \ - \ - arg._mp_size = (sa); \ - arg._mp_alloc = ((StgArrWords *)da)->words; \ - arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \ - \ - (r) = RET_PRIM_STGCALL1(I_,mpz_get_si,&arg); \ +#define integer2Intzh(r, sa,da) \ +{ StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \ + int size = sa; \ + \ + (r) = \ + ( size == 0 ) ? \ + 0 : \ + ( size < 0 && word0 != 0x8000000 ) ? \ + -(I_)word0 : \ + (I_)word0; \ } -#define integer2Wordzh(r, sa,da) \ -{ MP_INT arg; \ - \ - arg._mp_size = (sa); \ - arg._mp_alloc = ((StgArrWords *)da)->words; \ - arg._mp_d = (unsigned long int *) (BYTE_ARR_CTS(da)); \ - \ - (r) = RET_PRIM_STGCALL1(I_,mpz_get_ui,&arg); \ +#define integer2Wordzh(r, sa,da) \ +{ StgWord word0 = ((StgWord *)BYTE_ARR_CTS(da))[0]; \ + int size = sa; \ + (r) = ( size == 0 ) ? 0 : word0 ; \ } #define cmpIntegerzh(r, s1,d1, s2,d2) \ @@ -349,6 +355,20 @@ typedef union { (r) = RET_PRIM_STGCALL2(I_,mpz_cmp_si,&arg,i); \ } +/* I think mp_limb_t must be the same size as StgInt for this to work + * properly --SDM + */ +#define gcdIntzh(r,a,b) \ +{ StgInt aa = a; \ + r = (aa) ? (b) ? \ + RET_STGCALL3(StgInt, mpn_gcd_1, (mp_limb_t *)(&aa), 1, (mp_limb_t)(b)) \ + : abs(aa) \ + : abs(b); \ +} + +#define gcdIntegerIntzh(r,a,sb,b) \ + RET_STGCALL3(StgInt, mpn_gcd_1, (unsigned long int *) b, sb, (mp_limb_t)(a)) + /* The rest are all out-of-line: -------- */ /* Integer arithmetic */ @@ -357,6 +377,9 @@ EF_(minusIntegerzh_fast); EF_(timesIntegerzh_fast); EF_(gcdIntegerzh_fast); EF_(quotRemIntegerzh_fast); +EF_(quotIntegerzh_fast); +EF_(remIntegerzh_fast); +EF_(divExactIntegerzh_fast); EF_(divModIntegerzh_fast); /* Conversions */ @@ -473,11 +496,11 @@ LI_ stg_word64ToInt64 (StgWord64); #ifdef DEBUG #define BYTE_ARR_CTS(a) \ - ({ ASSERT(GET_INFO(a) == &ARR_WORDS_info); \ + ({ ASSERT(GET_INFO((StgArrWords *)(a)) == &ARR_WORDS_info); \ REAL_BYTE_ARR_CTS(a); }) #define PTRS_ARR_CTS(a) \ - ({ ASSERT((GET_INFO(a) == &ARR_PTRS_info) \ - || (GET_INFO(a) == &MUT_ARR_PTRS_info)); \ + ({ ASSERT((GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_FROZEN_info) \ + || (GET_INFO((StgMutArrPtrs *)(a)) == &MUT_ARR_PTRS_info)); \ REAL_PTRS_ARR_CTS(a); }) #else #define BYTE_ARR_CTS(a) REAL_BYTE_ARR_CTS(a) @@ -657,7 +680,9 @@ EF_(putMVarzh_fast); Delay/Wait PrimOps -------------------------------------------------------------------------- */ -/* Hmm, I'll think about these later. */ +EF_(waitReadzh_fast); +EF_(waitWritezh_fast); +EF_(delayzh_fast); /* ----------------------------------------------------------------------------- Primitive I/O, error-handling PrimOps @@ -695,17 +720,102 @@ EF_(makeStableNamezh_fast); #endif /* ----------------------------------------------------------------------------- - Parallel PrimOps. + Concurrency/Exception PrimOps. -------------------------------------------------------------------------- */ EF_(forkzh_fast); EF_(yieldzh_fast); EF_(killThreadzh_fast); EF_(seqzh_fast); +EF_(blockAsyncExceptionszh_fast); +EF_(unblockAsyncExceptionszh_fast); #define myThreadIdzh(t) (t = CurrentTSO) -/* Hmm, I'll think about these later. */ +extern int cmp_thread(const StgTSO *tso1, const StgTSO *tso2); + +/* ------------------------------------------------------------------------ + Parallel PrimOps + + A par in the Haskell code is ultimately translated to a parzh macro + (with a case wrapped around it to guarantee that the macro is actually + executed; see compiler/prelude/PrimOps.lhs) + ---------------------------------------------------------------------- */ + +#if defined(GRAN) +// hash coding changed from 2.10 to 4.00 +#define parzh(r,node) parZh(r,node) + +#define parZh(r,node) \ + PARZh(r,node,1,0,0,0,0,0) + +#define parAtzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1) + +#define parAtAbszh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2) + +#define parAtRelzh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3) + +#define parAtForNowzh(r,node,where,identifier,gran_info,size_info,par_info,rest) \ + parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0) + +#define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \ +{ \ + rtsSparkQ result; \ + if (closure_SHOULD_SPARK((StgClosure*)node)) { \ + rtsSparkQ result; \ + STGCALL6(newSpark, node,identifier,gran_info,size_info,par_info,local); \ + if (local==2) { /* special case for parAtAbs */ \ + STGCALL3(GranSimSparkAtAbs, result,(I_)where,identifier);\ + } else if (local==3) { /* special case for parAtRel */ \ + STGCALL3(GranSimSparkAtAbs, result,(I_)(CurrentProc+where),identifier); \ + } else { \ + STGCALL3(GranSimSparkAt, result,where,identifier); \ + } \ + } \ +} + +#define parLocalzh(r,node,identifier,gran_info,size_info,par_info,rest) \ + PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1) + +#define parGlobalzh(r,node,identifier,gran_info,size_info,par_info,rest) \ + PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0) + +#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \ +{ \ + if (closure_SHOULD_SPARK((StgClosure*)node)) { \ + rtsSpark *result; \ + result = RET_STGCALL6(rtsSpark*, newSpark, \ + node,identifier,gran_info,size_info,par_info,local);\ + STGCALL1(add_to_spark_queue,result); \ + STGCALL2(GranSimSpark, local,(P_)node); \ + } \ +} + +#define copyablezh(r,node) \ + /* copyable not yet implemented!! */ + +#define noFollowzh(r,node) \ + /* noFollow not yet implemented!! */ + +#endif /* GRAN */ + +#if defined(SMP) || defined(PAR) +#define parzh(r,node) \ +{ \ + extern unsigned int context_switch; \ + if (closure_SHOULD_SPARK((StgClosure *)node) && \ + SparkTl < SparkLim) { \ + *SparkTl++ = (StgClosure *)(node); \ + } \ + r = context_switch = 1; \ +} +#else +#define parzh(r,node) r = 1 +#endif + /* ----------------------------------------------------------------------------- Pointer equality -------------------------------------------------------------------------- */