do { \
DO_ASTK_HWM(); /* ticky-ticky profiling */ \
DO_BSTK_HWM(); \
- if (STKS_OVERFLOW_OP((a_headroom) + 1, (b_headroom) + 1)) { \
+ if (STKS_OVERFLOW_OP(((a_headroom) + 1), ((b_headroom) + 1))) { \
STACK_OVERFLOW(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter);\
} \
}while(0)
#define ZmZh(r,a,b) r=(a)-(b)
#define ZtZh(r,a,b) r=(a)*(b)
#define quotIntZh(r,a,b) r=(a)/(b)
+/* ZdZh not used??? --SDM */
#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
#define remIntZh(r,a,b) r=(a)%(b)
#define negateIntZh(r,a) r=-(a)
+
+/* Ever used ? -- SOF */
+#define absIntZh(a) r=(( (a) >= 0 ) ? (a) : (-(a)))
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+#define quotWordZh(r,a,b) r=((W_)a)/((W_)b)
+#define remWordZh(r,a,b) r=((W_)a)%((W_)b)
+
#define andZh(r,a,b) r=(a)&(b)
#define orZh(r,a,b) r=(a)|(b)
+#define xorZh(r,a,b) r=(a)^(b)
#define notZh(r,a) r=~(a)
#define shiftLZh(r,a,b) r=(a)<<(b)
-#define shiftRAZh(r,a,b) r=(a)>>(b)
#define shiftRLZh(r,a,b) r=(a)>>(b)
#define iShiftLZh(r,a,b) r=(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. -- sof 8/98
+*/
#define iShiftRAZh(r,a,b) r=(a)>>(b)
#define iShiftRLZh(r,a,b) r=(a)>>(b)
#define int2WordZh(r,a) r=(W_)(a)
#define word2IntZh(r,a) r=(I_)(a)
+
\end{code}
%************************************************************************
#define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
\end{code}
+
+%************************************************************************
+%* *
+\subsubsection[StgMacros-64-primops]{Primitive @Int64#@ and @Word64#@ ops}
+%* *
+%************************************************************************
+
+Apart from the Integer casting primops, all primops over 64-bit (i.e., long long)
+@Int64#@ and @Word64#@s are defined out-of-line. We just give the prototype
+of these primops here:
+
+\begin{code}
+#ifdef HAVE_LONG_LONG
+I_ stg_gtWord64 PROTO((StgWord64, StgWord64));
+I_ stg_geWord64 PROTO((StgWord64, StgWord64));
+I_ stg_eqWord64 PROTO((StgWord64, StgWord64));
+I_ stg_neWord64 PROTO((StgWord64, StgWord64));
+I_ stg_ltWord64 PROTO((StgWord64, StgWord64));
+I_ stg_leWord64 PROTO((StgWord64, StgWord64));
+
+I_ stg_gtInt64 PROTO((StgInt64, StgInt64));
+I_ stg_geInt64 PROTO((StgInt64, StgInt64));
+I_ stg_eqInt64 PROTO((StgInt64, StgInt64));
+I_ stg_neInt64 PROTO((StgInt64, StgInt64));
+I_ stg_ltInt64 PROTO((StgInt64, StgInt64));
+I_ stg_leInt64 PROTO((StgInt64, StgInt64));
+
+LW_ stg_remWord64 PROTO((StgWord64, StgWord64));
+LW_ stg_quotWord64 PROTO((StgWord64, StgWord64));
+
+LI_ stg_remInt64 PROTO((StgInt64, StgInt64));
+LI_ stg_quotInt64 PROTO((StgInt64, StgInt64));
+LI_ stg_negateInt64 PROTO((StgInt64));
+LI_ stg_plusInt64 PROTO((StgInt64, StgInt64));
+LI_ stg_minusInt64 PROTO((StgInt64, StgInt64));
+LI_ stg_timesInt64 PROTO((StgInt64, StgInt64));
+
+LW_ stg_and64 PROTO((StgWord64, StgWord64));
+LW_ stg_or64 PROTO((StgWord64, StgWord64));
+LW_ stg_xor64 PROTO((StgWord64, StgWord64));
+LW_ stg_not64 PROTO((StgWord64));
+
+LW_ stg_shiftL64 PROTO((StgWord64, StgInt));
+LW_ stg_shiftRL64 PROTO((StgWord64, StgInt));
+LI_ stg_iShiftL64 PROTO((StgInt64, StgInt));
+LI_ stg_iShiftRL64 PROTO((StgInt64, StgInt));
+LI_ stg_iShiftRA64 PROTO((StgInt64, StgInt));
+
+LI_ stg_intToInt64 PROTO((StgInt));
+I_ stg_int64ToInt PROTO((StgInt64));
+LW_ stg_int64ToWord64 PROTO((StgInt64));
+
+LW_ stg_wordToWord64 PROTO((StgWord));
+W_ stg_word64ToWord PROTO((StgWord64));
+LI_ stg_word64ToInt64 PROTO((StgWord64));
+#endif
+\end{code}
+
+
%************************************************************************
%* *
\subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
(dr) = (B_)(hp); /* dr is an StgByteArray */ \
}
+#define integer2WordZh(r, hp, aa,sa,da) \
+{ MP_INT arg; \
+ /* Does not allocate memory */ \
+ \
+ arg.alloc = (aa); \
+ arg.size = (sa); \
+ arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_ui,&arg); \
+}
+
+#define integerToInt64Zh(r, hp, aa,sa,da) \
+{ unsigned long int* d; \
+ StgInt64 res; \
+ /* Allocates memory. Chummy with gmp rep. */ \
+ \
+ d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ if ( (aa) == 0) { (res)=(LI_)0; } \
+ else if ( (aa) == 1) { (res)=(LI_)d[0]; } \
+ else { (res)=(LI_)d[0] + (LI_)d[1] * 0x100000000LL; } \
+ (r)=(LI_)( (sa) < 0 ? -res : res); \
+}
+
+#define integerToWord64Zh(r, hp, aa,sa,da) \
+{ unsigned long int* d; \
+ StgWord64 res; \
+ /* Allocates memory. Chummy with gmp rep. */ \
+ \
+ d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
+ \
+ if ( (aa) == 0) { (res)=(LW_)0; } \
+ else if ( (aa) == 1) { (res)=(LW_)d[0]; } \
+ else { (res)=(LW_)d[0] + (LW_)d[1] * 0x100000000ULL; } \
+ (r) = (res); \
+}
+
+#define int64ToIntegerZh(ar,sr,dr, hp, li) \
+{ StgInt64 val; /* to snaffle arg to avoid aliasing */ \
+ StgWord hi; \
+ int neg=0; \
+ \
+ val = (li); /* snaffle... */ \
+ \
+ SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
+ \
+ if ( val < 0LL ) { \
+ neg = 1; \
+ val = -val; \
+ } \
+ hi = (W_)((LW_)val / 0x100000000ULL); \
+ if ((LW_)(val) >= 0x100000000ULL) { (sr) = 2; (ar) = 2; (hp)[DATA_HS] = ((W_)val); (hp)[DATA_HS+1] = (hi); } \
+ else if ((val) != 0) { (sr) = 1; (ar) = 1; (hp)[DATA_HS] = ((W_)val); } \
+ else /* val==0 */ { (sr) = 0; (ar) = 1; } \
+ (sr) = ( neg ? -(sr) : (sr) ); \
+ (dr) = (B_)(hp); /* dr is an StgByteArray */ \
+}
+
+#define word64ToIntegerZh(ar,sr,dr, hp, lw) \
+{ StgWord64 val; /* to snaffle arg to avoid aliasing */ \
+ StgWord hi; \
+ \
+ val = (lw); /* snaffle... */ \
+ \
+ SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
+ \
+ hi = (W_)((LW_)val / 0x100000000ULL); \
+ if ((val) >= 0x100000000ULL ) { (sr) = 2; (ar) = 2; (hp)[DATA_HS] = ((W_)val); (hp)[DATA_HS+1] = (hi); } \
+ else if ((val) != 0) { (sr) = 1; (ar) = 1; (hp)[DATA_HS] = ((W_)val); } \
+ else /* val==0 */ { (sr) = 0; (ar) = 1; } \
+ (dr) = (B_)(hp); /* dr is an StgByteArray */ \
+}
+
+
+
\end{code}
Then there are a few oddments to make life easier:
|| m68k_TARGET_ARCH \
|| mipsel_TARGET_ARCH \
|| mipseb_TARGET_ARCH \
- || powerpc_TARGET_ARCH
+ || powerpc_TARGET_ARCH \
+ || rs6000_TARGET_ARCH
/* yes, it is IEEE floating point */
#include "ieee-flpt.h"
-#if alpha_dec_osf1_TARGET \
+#if alpha_TARGET_ARCH \
|| i386_TARGET_ARCH \
|| mipsel_TARGET_ARCH
\end{code}
\begin{code}
-#if alpha_dec_osf1_TARGET
+#if alpha_TARGET_ARCH
#define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
#else
#define encodeFloatZh(r, hp, aa,sa,da, expon) \
r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
}
-#if alpha_dec_osf1_TARGET
+#if alpha_TARGET_ARCH
#define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
#else
#define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
#endif /* __GNUC__ */
#endif /* not __m68k__ */
+
+#if HAVE_LONG_LONG
+extern STG_INLINE
+void
+ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+ word64_thing y;
+ y.w = src;
+ p_dest[0] = y.wu.dhi;
+ p_dest[1] = y.wu.dlo;
+}
+
+extern STG_INLINE
+StgWord64
+PK_Word64(W_ p_src[])
+{
+ word64_thing y;
+ y.wu.dhi = p_src[0];
+ y.wu.dlo = p_src[1];
+ return(y.w);
+}
+
+extern STG_INLINE
+void
+ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+ int64_thing y;
+ y.i = src;
+ p_dest[0] = y.iu.dhi;
+ p_dest[1] = y.iu.dlo;
+}
+
+extern STG_INLINE
+StgInt64
+PK_Int64(W_ p_src[])
+{
+ int64_thing y;
+ y.iu.dhi = p_src[0];
+ y.iu.dlo = p_src[1];
+ return(y.i);
+}
+#endif
+
\end{code}
%************************************************************************
#define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-#define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
/* result ("r") arg ignored in write macros! */
#define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
-#define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
-#define writeFloatArrayZh(a,i,v) \
- ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
-#define writeDoubleArrayZh(a,i,v) \
- ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
+#define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeStablePtrArrayZh(a,i,v) ((StgStablePtr *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeInt64ArrayZh(a,i,v) ((LI_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeWord64ArrayZh(a,i,v) ((LW_ *)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
+#define writeFloatArrayZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
+#define writeDoubleArrayZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
#define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
-#define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
-#define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexStablePtrArrayZh(r,a,i) indexStablePtrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexInt64ArrayZh(r,a,i) indexInt64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+#define indexWord64ArrayZh(r,a,i) indexWord64OffAddrZh(r,BYTE_ARR_CTS(a),i)
+
+#define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexStablePtrOffForeignObjZh(r,fo,i) indexStablePtrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexInt64OffForeignObjZh(r,fo,i) indexInt64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexWord64OffForeignObjZh(r,fo,i) indexWord64OffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+
+#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
+#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
+#define indexStablePtrOffAddrZh(r,a,i) r= ((StgStablePtr *)(a))[i]
+#define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i]
+#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
+#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
+#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
+#define indexInt64OffAddrZh(r,a,i) r= ((LI_ *)(a))[i]
+#define indexWord64OffAddrZh(r,a,i) r= ((LW_ *)(a))[i]
+
+#define writeCharOffAddrZh(a,i,v) ((C_ *)(a))[i] = (v)
+#define writeIntOffAddrZh(a,i,v) ((I_ *)(a))[i] = (v)
+#define writeStablePtrOffAddrZh(a,i,v) ((StgStablePtr *)(a))[i] = (v)
+#define writeWordOffAddrZh(a,i,v) ((W_ *)(a))[i] = (v)
+#define writeAddrOffAddrZh(a,i,v) ((PP_)(a))[i] = (v)
+#define writeForeignObjOffAddrZh(a,i,v) ((PP_)(a))[i] = ForeignObj_CLOSURE_DATA(v)
+#define writeFloatOffAddrZh(a,i,v) ASSIGN_FLT((P_) (((StgFloat *)(a)) + i),v)
+#define writeDoubleOffAddrZh(a,i,v) ASSIGN_DBL((P_) (((StgDouble *)(a)) + i),v)
+#define writeInt64OffAddrZh(a,i,v) ((LI_ *)(a))[i] = (v)
+#define writeWord64OffAddrZh(a,i,v) ((LW_ *)(a))[i] = (v)
-#define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
-#define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
-#define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
-#define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
-#define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
/* Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable
}while(0)
#define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
+
+#define sizeofByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
+#define sizeofMutableByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
\end{code}
Now the \tr{newArr*} ops:
For char arrays, the size is in {\em BYTES}.
\begin{code}
-#define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
-#define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
-#define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
-#define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
-#define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
+#define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
+#define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
+#define newStablePtrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgStablePtr))
+#define newWordArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(W_))
+#define newInt64ArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(LI_))
+#define newWord64ArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(LW_))
+#define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
+#define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
+#define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
#define newByteArray(r,liveness,n) \
{ \
%************************************************************************
\begin{code}
-ED_(Prelude_Z91Z93_closure);
+ED_(PrelBase_Z91Z93_closure);
+
+#define sameMVarZh(r,a,b) r=(I_)((a)==(b))
#define newSynchVarZh(r, hp) \
{ \
ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \
SET_SVAR_HDR(hp,EmptySVar_info,CCC); \
- SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Prelude_Z91Z93_closure; \
+ SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = PrelBase_Z91Z93_closure; \
r = hp; \
}
\end{code}
#define takeMVarZh(r, liveness, node) \
{ \
while (INFO_PTR(node) != (W_) FullSVar_info) { \
- if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \
+ if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
SVAR_HEAD(node) = CurrentTSO; \
else \
TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \
+ TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
SVAR_TAIL(node) = CurrentTSO; \
DO_YIELD(liveness << 1); \
} \
SET_INFO_PTR(node, EmptySVar_info); \
r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = Prelude_Z91Z93_closure; \
+ SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
}
#else
} \
SET_INFO_PTR(node, EmptySVar_info); \
r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = Prelude_Z91Z93_closure; \
+ SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
}
#endif
SET_INFO_PTR(node, FullSVar_info); \
SVAR_VALUE(node) = value; \
tso = SVAR_HEAD(node); \
- if (tso != (P_) Prelude_Z91Z93_closure) { \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
if (DO_QP_PROF) \
STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- if (ThreadQueueHd == Prelude_Z91Z93_closure) \
+ if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
ThreadQueueHd = tso; \
else \
TSO_LINK(ThreadQueueTl) = tso; \
ThreadQueueTl = tso; \
SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \
+ TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
+ if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
+ SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
} \
}
SET_INFO_PTR(node, FullSVar_info); \
SVAR_VALUE(node) = value; \
tso = SVAR_HEAD(node); \
- if (tso != (P_) Prelude_Z91Z93_closure) { \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
if (DO_QP_PROF) \
STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- if (RunnableThreadsHd == Prelude_Z91Z93_closure) \
+ if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
RunnableThreadsHd = tso; \
else \
TSO_LINK(RunnableThreadsTl) = tso; \
RunnableThreadsTl = tso; \
SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \
+ TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
+ if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
+ SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
} \
}
#define readIVarZh(r, liveness, node) \
{ \
if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
- if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \
+ if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
SVAR_HEAD(node) = CurrentTSO; \
else \
TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \
+ TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
SVAR_TAIL(node) = CurrentTSO; \
DO_YIELD(liveness << 1); \
} \
EXIT(EXIT_FAILURE); \
} \
tso = SVAR_HEAD(node); \
- if (tso != (P_) Prelude_Z91Z93_closure) { \
- if (ThreadQueueHd == Prelude_Z91Z93_closure) \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
+ if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
ThreadQueueHd = tso; \
else \
TSO_LINK(ThreadQueueTl) = tso; \
- while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \
+ while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) { \
if (DO_QP_PROF) \
STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
tso = TSO_LINK(tso); \
EXIT(EXIT_FAILURE); \
} \
tso = SVAR_HEAD(node); \
- if (tso != (P_) Prelude_Z91Z93_closure) { \
- if (RunnableThreadsHd == Prelude_Z91Z93_closure) \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
+ if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
RunnableThreadsHd = tso; \
else \
TSO_LINK(RunnableThreadsTl) = tso; \
- while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \
+ while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) { \
if (DO_QP_PROF) \
STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
tso = TSO_LINK(tso); \
#define delayZh(liveness, us) \
{ \
- if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
WaitingThreadsHd = CurrentTSO; \
else \
TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
DO_YIELD(liveness << 1); \
}
#define waitReadZh(liveness, fd) \
{ \
- if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
WaitingThreadsHd = CurrentTSO; \
else \
TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
DO_YIELD(liveness << 1); \
}
#define waitWriteZh(liveness, fd) \
{ \
- if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
WaitingThreadsHd = CurrentTSO; \
else \
TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
DO_YIELD(liveness << 1); \
}
JMP_(ErrorIO_innards); \
} while(0)
+/* These are now, I believe, unused. (8/98 SOF) */
#if !defined(CALLER_SAVES_SYSTEM)
/* can use the macros */
#define stg_getc(stream) getc((FILE *) (stream))
IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
IF_RTS(void AwaitEvent(I_ delta);)
-#ifdef _POSIX_SOURCE
+#if defined(_POSIX_SOURCE) && !defined(nextstep3_TARGET_OS)
+ /* For nextstep3_TARGET_OS comment see stgdefs.h. CaS */
extern I_ sig_install PROTO((I_, I_, sigset_t *));
#define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
#define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
+char* createAdjustor PROTO((int cc,StgStablePtr hptr, StgFunPtr wptr));
+void freeAdjustor PROTO((void* ptr));
+
#endif /* !PAR */
IF_RTS(extern I_ ErrorIO_call_count;)
\begin{code}
#ifdef CONCURRENT
-ED_(Prelude_Z91Z93_closure);
+ED_(PrelBase_Z91Z93_closure);
ED_(True_closure);
#if defined(GRAN)
extern I_ required_thread_count;
#ifdef PAR
-#define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++
+#define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++; sparksCreated++
#else
#define COUNT_SPARK
#endif
}
#endif /* GRAN */
+
+#endif /* CONCURRENT */
\end{code}
The following seq# code should only be used in unoptimized code.
Be warned: it's a potential bug-farm.
+[SOF 8/98:
+ Yes, it completely fails to work for function values, since a PAP
+ closure will be constructed when the arg satisfaction check fails.
+ This PAP closure will add the magic values that gets pushed on the B stack
+ before entering the 'seqee' (new word!), as Jim is just about to tell
+ us about. Let's hear what he's got to say:
+]
First we push two words on the B stack: the current value of RetReg
(which may or may not be live), and a continuation snatched largely out
RetReg is restored, and we jump to the continuation, completing the
primop and going on our merry way.
+[ To workaround the shortcoming of not being able to deal with partially
+ applied values, we explicitly prohibit this at the Haskell source level
+ (i.e., we don't define an Eval instance for (->) ).
+]
+
\begin{code}
ED_RO_(vtbl_seq);
r = 1; /* Should be unnecessary */ \
})
-#endif /* CONCURRENT */
\end{code}
%************************************************************************
#ifndef PAR
StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
+StgInt eqStablePtr PROTO((StgStablePtr p1, StgStablePtr p2));
#define makeForeignObjZh(r, liveness, mptr, finalise) \
do { \
ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
StorageMgrInfo.ForeignObjList = result; \
\
-/* \
- printf("DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
+ \
+ /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
result, \
result[0],result[1], \
- result[2],result[3]); \
-*/ \
+ result[2],result[3]);*/ \
+ \
CHECK_ForeignObj_CLOSURE( result ); \
VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
\
(r) = (P_) result; \
} while (0)
+#define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
+
#else
#define makeForeignObjZh(r, liveness, mptr, finalise) \
do { \
EXIT(EXIT_FAILURE); \
} while(0)
+#define writeForeignObjZh(res,datum) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
+ EXIT(EXIT_FAILURE); \
+} while(0)
+
#endif /* !PAR */
\end{code}
projects / ghc-hetmet.git / blobdiff