General things; note: general-but-``machine-dependent'' macros are
given in \tr{StgMachDeps.lh}.
\begin{code}
-#define STG_MAX(a,b) (((a)>=(b)) ? (a) : (b))
+I_ STG_MAX PROTO((I_, I_)); /* GCC -Wall loves prototypes */
+
+extern STG_INLINE
+I_
+STG_MAX(I_ a, I_ b) { return((a >= b) ? a : b); }
+/* NB: the naive #define macro version of STG_MAX
+ can lead to exponential CPP explosion, if you
+ have very-nested STG_MAXes.
+*/
/*
Macros to combine two short words into a single
\begin{code}
#define ARGS_CHK_A(n) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
+ }
#define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
Node = (P_) closure_addr; \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
-
+ }
#define ARGS_CHK_B(n) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
+ }
#define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
Node = (P_) closure_addr; \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
-
+ }
\end{code}
%************************************************************************
NB: args @a@ and @b@ are pre-direction-ified!
\begin{code}
-extern I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
+I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
+int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
#if ! defined(CONCURRENT)
#else /* threaded */
-extern I_ StackOverflow PROTO((W_, W_));
+I_ StackOverflow PROTO((W_, W_));
/*
* On a uniprocessor, we do *NOT* context switch on a stack overflow
do { \
DO_ASTK_HWM(); /* ticky-ticky profiling */ \
DO_BSTK_HWM(); \
- /* SET_ACTIVITY(ACT_STK_CHK); /? SPAT counting -- no, using page faulting */ \
- 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)
%************************************************************************
%* *
-\subsubsection[StgMacros-arity-chks]{Arity checks (for debugging)}
-%* *
-%************************************************************************
-
-This is a debugging feature. Each call to fast-entry-point code sets
-@ExpectedArity@ to some value, and the callee then checks that the
-value is as expected.
-
-\begin{code}
-#if defined(__DO_ARITY_CHKS__)
-
-extern I_ ExpectedArity;
-extern void ArityError PROTO((I_)) STG_NORETURN;
-
-#define SET_ARITY(n) do { ExpectedArity = (n); } while(0)
-#define CHK_ARITY(n) \
- do { \
- if (ExpectedArity != (n)) { \
- ULTRASAFESTGCALL1(void,(void *, I_),ArityError,n); \
- }}while(0)
-
-#else /* ! __DO_ARITY_CHKS__: normal case */
-
-#define SET_ARITY(n) /* nothing */
-#define CHK_ARITY(n) /* nothing */
-
-#endif /* ! __DO_ARITY_CHKS__ */
-\end{code}
-
-%************************************************************************
-%* *
\subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
%* *
%************************************************************************
happens in a GC,'' in \tr{SMinterface.lh}.
\begin{code}
-extern void PerformGC PROTO((W_));
+void PerformGC PROTO((W_));
void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_ always_reenter_node, rtsBool do_full_collection));
void checkInCCallGC(STG_NO_ARGS);
#define HEAP_OVERFLOW(liveness,n,reenter) \
do { \
- SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
DO_GC((((W_)n)<<8)|(liveness)); \
- SET_ACTIVITY(ACT_GC_STOP); \
} while (0)
#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
#else /* CONCURRENT */
-extern void ReallyPerformThreadGC PROTO((W_, rtsBool));
+void ReallyPerformThreadGC PROTO((W_, rtsBool));
#define HEAP_OVERFLOW(liveness,n,reenter) \
do { \
- SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
- SET_ACTIVITY(ACT_GC_STOP); \
} while (0)
#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
/* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
ALLOC_HEAP(n); /* ticky profiling */ \
GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim)) { \
/* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
- } \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */ \
- }while(0)
+ }}while(0)
#else
/* TICKY_PARANOIA(__FILE__, __LINE__); */ \
PRE_FETCH(n); \
ALLOC_HEAP(n); /* ticky profiling */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
HEAP_OVERFLOW(liveness_mask,n,reenter); \
} \
/* TICKY_PARANOIA(__FILE__, __LINE__); */ \
PRE_FETCH(n); \
ALLOC_HEAP(n); /* ticky profiling */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
HEAP_OVERFLOW(liveness_mask,n,reenter); \
n = TSO_ARG1(CurrentTSO); \
- } \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
-} while(0)
+ }} while(0)
#else
#define ltCharZh(r,a,b) r=(I_)((a)< (b))
#define leCharZh(r,a,b) r=(I_)((a)<=(b))
-#define gtIntZh(r,a,b) r=(I_)((a) >(b))
-#define geIntZh(r,a,b) r=(I_)((a)>=(b))
-#define eqIntZh(r,a,b) r=(I_)((a)==(b))
-#define neIntZh(r,a,b) r=(I_)((a)!=(b))
-#define ltIntZh(r,a,b) r=(I_)((a) <(b))
-#define leIntZh(r,a,b) r=(I_)((a)<=(b))
+/* Int comparisons: >#, >=# etc */
+#define ZgZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZh(r,a,b) r=(I_)((a)<=(b))
#define gtWordZh(r,a,b) r=(I_)((a) >(b))
#define geWordZh(r,a,b) r=(I_)((a)>=(b))
#define ltFloatZh(r,a,b) r=(I_)((a)< (b))
#define leFloatZh(r,a,b) r=(I_)((a)<=(b))
-#define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
-#define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
-#define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
-#define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
-#define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
-#define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
+/* Double comparisons: >##, >=#@ etc */
+#define ZgZhZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZhZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
\end{code}
%************************************************************************
\begin{code}
I_ stg_div PROTO((I_ a, I_ b));
-#define plusIntZh(r,a,b) r=(a)+(b)
-#define minusIntZh(r,a,b) r=(a)-(b)
-#define timesIntZh(r,a,b) r=(a)*(b)
+#define ZpZh(r,a,b) r=(a)+(b)
+#define ZmZh(r,a,b) r=(a)-(b)
+#define ZtZh(r,a,b) r=(a)*(b)
#define quotIntZh(r,a,b) r=(a)/(b)
-#define divIntZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(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)
%************************************************************************
\begin{code}
-#define plusDoubleZh(r,a,b) r=(a)+(b)
-#define minusDoubleZh(r,a,b) r=(a)-(b)
-#define timesDoubleZh(r,a,b) r=(a)*(b)
-#define divideDoubleZh(r,a,b) r=(a)/(b)
+#define ZpZhZh(r,a,b) r=(a)+(b)
+#define ZmZhZh(r,a,b) r=(a)-(b)
+#define ZtZhZh(r,a,b) r=(a)*(b)
+#define ZdZhZh(r,a,b) r=(a)/(b)
#define negateDoubleZh(r,a) r=-(a)
#define int2DoubleZh(r,a) r=(StgDouble)(a)
#define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
#define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
#define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-#define powerDoubleZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
+/* Power: **## */
+#define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
\end{code}
%************************************************************************
UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
SAVE_Hp = Hp; /* Hand over the hp */ \
DEBUG_SetGMPAllocBudget(n) \
- OptSaveHpLimRegister() \
}while(0)
#define GMP_HEAP_HANDBACK() \
Hp = SAVE_Hp; \
- DEBUG_ResetGMPAllocBudget() \
- OptRestoreHpLimRegister()
+ DEBUG_ResetGMPAllocBudget()
\end{code}
\begin{code}
#endif
\end{code}
-\begin{code}
-#if defined (LIFE_PROFILE)
-
-#define OptSaveHpLimRegister() \
- SAVE_HpLim = HpLim
-#define OptRestoreHpLimRegister() \
- HpLim = SAVE_HpLim
-
-#else /* ! LIFE_PROFILE */
-
-#define OptSaveHpLimRegister() /* nothing */
-#define OptRestoreHpLimRegister() /* nothing */
-
-#endif /* ! LIFE_PROFILE */
-\end{code}
-
The real business (defining Integer primops):
\begin{code}
#define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
these pretty magical support functions, essentially stolen from Lennart:
\begin{code}
StgFloat __encodeFloat PROTO((MP_INT *, I_));
-void __decodeFloat PROTO((MP_INT * /*result1*/,
+void __decodeFloat PROTO((MP_INT * /*result1*/,
I_ * /*result2*/,
StgFloat));
StgDouble __encodeDouble PROTO((MP_INT *, I_));
-void __decodeDouble PROTO((MP_INT * /*result1*/,
+void __decodeDouble PROTO((MP_INT * /*result1*/,
I_ * /*result2*/,
StgDouble));
\end{code}
|| alpha_TARGET_ARCH \
|| hppa1_1_TARGET_ARCH \
|| i386_TARGET_ARCH \
- || i486_TARGET_ARCH \
|| m68k_TARGET_ARCH \
|| mipsel_TARGET_ARCH \
|| mipseb_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 \
- || i486_TARGET_ARCH \
|| mipsel_TARGET_ARCH
#undef BIGENDIAN /* little-endian weirdos... */
\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) \
\begin{code}
#if alpha_TARGET_ARCH \
|| i386_TARGET_ARCH \
- || i486_TARGET_ARCH \
|| m68k_TARGET_ARCH
#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
#if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
-extern void ASSIGN_DBL PROTO((W_ [], StgDouble));
-extern StgDouble PK_DBL PROTO((W_ []));
-extern void ASSIGN_FLT PROTO((W_ [], StgFloat));
-extern StgFloat PK_FLT PROTO((W_ []));
+void ASSIGN_DBL PROTO((W_ [], StgDouble));
+StgDouble PK_DBL PROTO((W_ []));
+void ASSIGN_FLT PROTO((W_ [], StgFloat));
+StgFloat PK_FLT PROTO((W_ []));
#else /* yes, its __GNUC__ && we really want them */
#else /* ! sparc */
+/* (not very) forward prototype declarations */
+void ASSIGN_DBL PROTO((W_ [], StgDouble));
+StgDouble PK_DBL PROTO((W_ []));
+void ASSIGN_FLT PROTO((W_ [], StgFloat));
+StgFloat PK_FLT PROTO((W_ []));
+
extern STG_INLINE
void
ASSIGN_DBL(W_ p_dest[], StgDouble src)
extern I_ resetGenSymZh(STG_NO_ARGS);
extern I_ incSeqWorldZh(STG_NO_ARGS);
-/* sigh again: without these some (notably "float") willnae work */
-extern I_ long2bytes__ PROTO((long, unsigned char *));
-extern I_ int2bytes__ PROTO((int, unsigned char *));
-extern I_ short2bytes__ PROTO((short, unsigned char *));
-extern I_ float2bytes__ PROTO((float, unsigned char *));
-extern I_ double2bytes__ PROTO((double, unsigned char *));
-
-/* these may not be necessary; and they create warnings (WDP) */
-extern I_ bytes2long__ PROTO((P_, I_ *));
-extern I_ bytes2int__ PROTO((P_, I_ *));
-extern I_ bytes2short__ PROTO((P_, I_ *));
-extern I_ bytes2float__ PROTO((P_, StgFloat *));
-extern I_ bytes2double__ PROTO((P_, StgDouble *));
-
extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
\end{code}
OK, the easy ops first: (all except \tr{newArr*}:
-VERY IMPORTANT! The read/write/index primitive ops
+(OLD:) VERY IMPORTANT! The read/write/index primitive ops
on @ByteArray#@s index the array using a {\em BYTE} offset, even
if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
This is because you might be trying to take apart a C struct, where
the offset from the start of the struct isn't a multiple of the
size of the thing you're getting. Hence the @(char *)@ casts.
+EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
+are in Blahs. WDP 95/08
+
In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
we cast to @P_@, because you can't index off an uncast \tr{void *}.
#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 indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
+#define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(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 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]
for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
*p = (W_) (init); \
} \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
\
r = result; \
}
%************************************************************************
\begin{code}
-ED_(Nil_closure);
+ED_(PrelBase_Z91Z93_closure);
#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) = Nil_closure; \
+ SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = PrelBase_Z91Z93_closure; \
r = hp; \
}
\end{code}
\begin{code}
#ifdef CONCURRENT
-extern void Yield PROTO((W_));
+void Yield PROTO((W_));
#define takeMVarZh(r, liveness, node) \
{ \
while (INFO_PTR(node) != (W_) FullSVar_info) { \
- if (SVAR_HEAD(node) == Nil_closure) \
+ if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
SVAR_HEAD(node) = CurrentTSO; \
else \
TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) Nil_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) = Nil_closure; \
+ SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
}
#else
} \
SET_INFO_PTR(node, EmptySVar_info); \
r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = Nil_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_) Nil_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 == Nil_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_) Nil_closure; \
- if(SVAR_HEAD(node) == (P_) Nil_closure) \
- SVAR_TAIL(node) = (P_) Nil_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_) Nil_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 == Nil_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_) Nil_closure; \
- if(SVAR_HEAD(node) == (P_) Nil_closure) \
- SVAR_TAIL(node) = (P_) Nil_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) == Nil_closure) \
+ if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
SVAR_HEAD(node) = CurrentTSO; \
else \
TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) Nil_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_) Nil_closure) { \
- if (ThreadQueueHd == Nil_closure) \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
+ if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
ThreadQueueHd = tso; \
else \
TSO_LINK(ThreadQueueTl) = tso; \
- while(TSO_LINK(tso) != Nil_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_) Nil_closure) { \
- if (RunnableThreadsHd == Nil_closure) \
+ if (tso != (P_) PrelBase_Z91Z93_closure) { \
+ if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
RunnableThreadsHd = tso; \
else \
TSO_LINK(RunnableThreadsTl) = tso; \
- while(TSO_LINK(tso) != Nil_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 == Nil_closure) \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
WaitingThreadsHd = CurrentTSO; \
else \
TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = Nil_closure; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
DO_YIELD(liveness << 1); \
}
/* ToDo: something for GRAN */
-#define waitZh(liveness, fd) \
+#define waitReadZh(liveness, fd) \
{ \
- if (WaitingThreadsTl == Nil_closure) \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
WaitingThreadsHd = CurrentTSO; \
else \
TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = Nil_closure; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
DO_YIELD(liveness << 1); \
}
#else
-#define waitZh(liveness, fd) \
+#define waitReadZh(liveness, fd) \
{ \
fflush(stdout); \
- fprintf(stderr, "wait#: unthreaded build.\n"); \
+ fprintf(stderr, "waitRead#: unthreaded build.\n"); \
+ EXIT(EXIT_FAILURE); \
+ }
+
+#endif
+
+#ifdef CONCURRENT
+
+/* ToDo: something for GRAN */
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif HAVE_SYS_TYPES_H */
+
+#define waitWriteZh(liveness, fd) \
+ { \
+ if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
+ WaitingThreadsHd = CurrentTSO; \
+ else \
+ TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
+ WaitingThreadsTl = CurrentTSO; \
+ TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
+ TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
+ DO_YIELD(liveness << 1); \
+ }
+
+#else
+
+#define waitWriteZh(liveness, fd) \
+ { \
+ fflush(stdout); \
+ fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
EXIT(EXIT_FAILURE); \
}
void unblockUserSignals(STG_NO_ARGS);
IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
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)
StgInt getErrorHandler(STG_NO_ARGS);
#ifndef PAR
-void raiseError PROTO((StgStablePtr handler));
+void raiseError PROTO((StgStablePtr handler));
StgInt catchError PROTO((StgStablePtr newErrorHandler));
#endif
void decrementErrorCount(STG_NO_ARGS);
-#define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
+#define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
#define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
\end{code}
#define deRefStablePtrZh(ri,sp) \
ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
-
\end{code}
Declarations for other stable pointer operations.
IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
-IF_RTS(extern I_ noBlackHoles;)
-IF_RTS(extern I_ SM_word_stk_size;)
EXTFUN(stopPerformIODirectReturn);
EXTFUN(startPerformIO);
any strictly increasing expression will do here */
#define CalcNewNoSPtrs( i ) ((i)*2 + 100)
-extern void enlargeSPTable PROTO((P_, P_));
+void enlargeSPTable PROTO((P_, P_));
#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
do { \
\
newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
+ CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
stablePtr = newSP; \
} while (0)
\begin{code}
#ifdef CONCURRENT
-ED_(Nil_closure);
+ED_(PrelBase_Z91Z93_closure);
ED_(True_closure);
#if defined(GRAN)
-#define parZh(r,hp,node,rest) \
- PARZh(r,hp,node,rest,0,0)
+#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 parAtZh(r,hp,node,where,identifier,rest) \
- parATZh(r,hp,node,where,identifier,rest,1)
+#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,hp,node,where,identifier,rest) \
- parATZh(r,hp,node,where,identifier,rest,0)
+#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,hp,node,where,identifier,rest,local) \
+#define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
{ \
sparkq result; \
if (SHOULD_SPARK(node)) { \
- result = NewSpark((P_)node,identifier,local); \
- SAFESTGCALL3(void,(W_),GranSimSparkAt,result,where,identifier); \
+ SaveAllStgRegs(); \
+ { sparkq result; \
+ result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local); \
+ if (local==2) { /* special case for parAtAbs */ \
+ GranSimSparkAtAbs(result,(I_)where,identifier);\
+ } else if (local==3) { /* special case for parAtRel */ \
+ GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier); \
+ } else { \
+ GranSimSparkAt(result,where,identifier); \
+ } \
+ context_switch = 1; \
+ } \
+ RestoreAllStgRegs(); \
} else if (do_qp_prof) { \
I_ tid = threadId++; \
SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
} \
- r = (rest); \
+ r = 1; /* return code for successful spark -- HWL */ \
}
-#define parLocalZh(r,hp,node,identifier,rest) \
- PARZh(r,hp,node,rest,identifier,1)
+#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,hp,node,identifier,rest) \
- PARZh(r,hp,node,rest,identifier,0)
+#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,hp,node,rest,identifier,local) \
+#if 1
+
+#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
+{ \
+ if (SHOULD_SPARK(node)) { \
+ SaveAllStgRegs(); \
+ { sparkq result; \
+ result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
+ add_to_spark_queue(result); \
+ GranSimSpark(local,(P_)node); \
+ context_switch = 1; \
+ } \
+ RestoreAllStgRegs(); \
+ } else if (do_qp_prof) { \
+ I_ tid = threadId++; \
+ SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
+ } \
+ r = 1; /* return code for successful spark -- HWL */ \
+}
+
+#else
+
+#define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
{ \
sparkq result; \
if (SHOULD_SPARK(node)) { \
- result = NewSpark((P_)node,identifier,local); \
+ result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
ADD_TO_SPARK_QUEUE(result); \
SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \
- /* context_switch = 1; not needed any more -- HWL */ \
+ /* context_switch = 1; not needed any more -- HWL */ \
} else if (do_qp_prof) { \
I_ tid = threadId++; \
SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
} \
- r = (rest); \
+ r = 1; /* return code for successful spark -- HWL */ \
}
+#endif
+
+#define copyableZh(r,node) \
+ /* copyable not yet implemented!! */
+
+#define noFollowZh(r,node) \
+ /* noFollow not yet implemented!! */
+
#else /* !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
if (SHOULD_SPARK(node) && \
PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
*PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
- } else if (DO_QP_PROF) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
+ } else { \
+ sparksIgnored++; \
+ if (DO_QP_PROF) { \
+ I_ tid = threadId++; \
+ SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
+ } \
} \
r = 1; /* Should not be necessary */ \
}
+#endif /* GRAN */
+
+#endif /* CONCURRENT */
\end{code}
The following seq# code should only be used in unoptimized code.
#define seqZh(r,liveness,node) \
({ \
__label__ cont; \
- STK_CHK(liveness,0,2,0,0,0,0); \
- SpB -= BREL(2); \
+ /* STK_CHK(liveness,0,2,0,0,0,0); */ \
+ /* SpB -= BREL(2); */ \
SpB[BREL(0)] = (W_) RetReg; \
SpB[BREL(1)] = (W_) &&cont; \
RetReg = (StgRetAddr) vtbl_seq; \
r = 1; /* Should be unnecessary */ \
})
-#endif /* GRAN */
-#endif /* CONCURRENT */
\end{code}
%************************************************************************
%* *
-\subsubsection[StgMacros-malloc-ptrs]{Malloc Pointers}
+\subsubsection[StgMacros-foreign-objects]{Foreign Objects}
%* *
%************************************************************************
-This macro is used to construct a MallocPtr on the heap after a ccall.
-Since MallocPtr's are like arrays in many ways, this is heavily based
-on the stuff for arrays above.
+[Based on previous MallocPtr comments -- SOF]
+
+This macro is used to construct a ForeignObj on the heap.
What this does is plug the pointer (which will be in a local
-variable), into a fresh heap object and then sets a result (which will
-be a register) to point to the fresh heap object.
+variable) together with its finalising/free routine, into a fresh heap
+object and then sets a result (which will be a register) to point
+to the fresh heap object.
+
+To accommodate per-object finalisation, augment the macro with a
+finalisation routine argument. Nothing spectacular, just plug the
+pointer to the routine into the ForeignObj -- SOF 4/96
Question: what's this "SET_ACTIVITY" stuff - should I be doing this
too? (It's if you want to use the SPAT profiling tools to
characterize program behavior by ``activity'' -- tail-calling,
-heap-checking, etc. -- see RednCounts.lh. It is quite specialized.
+heap-checking, etc. -- see Ticky.lh. It is quite specialized.
WDP 95/1)
+(Swapped first two arguments to make it come into line with what appears
+to be `standard' format, return register then liveness mask. -- SOF 4/96)
+
\begin{code}
#ifndef PAR
-StgInt eqMallocPtr PROTO((StgMallocPtr p1, StgMallocPtr p2));
-void FreeMallocPtr PROTO((StgMallocPtr mp));
+StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
-#define constructMallocPtr(liveness, r, mptr) \
-do { \
- P_ result; \
- \
- HEAP_CHK(liveness, _FHS + MallocPtr_SIZE,0); \
- CC_ALLOC(CCC,_FHS + MallocPtr_SIZE,MallocPtr_K); /* cc prof */ \
+#define makeForeignObjZh(r, liveness, mptr, finalise) \
+do { \
+ P_ result; \
+ \
+ HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0); \
+ CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */ \
\
- result = Hp + 1 - (_FHS + MallocPtr_SIZE); \
- SET_MallocPtr_HDR(result,MallocPtr_info,CCC,_FHS + MallocPtr_SIZE,0); \
- MallocPtr_CLOSURE_DATA(result) = mptr; \
- MallocPtr_CLOSURE_LINK(result) = StorageMgrInfo.MallocPtrList; \
- StorageMgrInfo.MallocPtrList = result; \
+ result = Hp + 1 - (_FHS + ForeignObj_SIZE); \
+ SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
+ ForeignObj_CLOSURE_DATA(result) = (P_)mptr; \
+ ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise; \
+ ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
+ StorageMgrInfo.ForeignObjList = result; \
+ \
\
-/* \
- printf("DEBUG: MallocPtr(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]); \
-*/ \
- CHECK_MallocPtr_CLOSURE( result ); \
- VALIDATE_MallocPtrList( StorageMgrInfo.MallocPtrList ); \
+ 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 constructMallocPtr(liveness, r, mptr) \
+#define makeForeignObjZh(r, liveness, mptr, finalise) \
+do { \
+ fflush(stdout); \
+ fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
+ EXIT(EXIT_FAILURE); \
+} while(0)
+
+#define writeForeignObjZh(res,datum) \
do { \
fflush(stdout); \
- fprintf(stderr, "constructMallocPtr: no malloc pointer support.\n");\
+ fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
EXIT(EXIT_FAILURE); \
} while(0)
projects / ghc-hetmet.git / blobdiff