+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[StgMacros]{C macros used in GHC-generated \tr{.hc} files}
-
-\begin{code}
-#ifndef STGMACROS_H
-#define STGMACROS_H
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-abbrev]{Abbreviatory(?) and general macros}
-%* *
-%************************************************************************
-
-Mere abbreviations:
-\begin{code}
-/* for function declarations */
-#define STGFUN(f) F_ f(STG_NO_ARGS)
-#define STATICFUN(f) static F_ f(STG_NO_ARGS)
-
-/* for functions/data that are really external to this module */
-#define EXTFUN(f) extern F_ f(STG_NO_ARGS)
-#define EXTDATA(d) extern W_ d[]
-#define EXTDATA_RO(d) extern const W_ d[] /* read-only */
-
-/* for fwd decls to functions/data somewhere else in this module */
-/* (identical for the mo') */
-#define INTFUN(f) static F_ f(STG_NO_ARGS)
-#define INTDATA(d) extern W_ d[]
-#define INTDATA_RO(d) extern const W_ d[] /* read-only */
-
-/* short forms of most of the above */
-
-#define FN_(f) F_ f(STG_NO_ARGS)
-#define IFN_(f) static F_ f(STG_NO_ARGS)
-#define EF_(f) extern F_ f(STG_NO_ARGS)
-#define ED_(d) extern W_ d[]
-#define ED_RO_(d) extern const W_ d[] /* read-only */
-#define IF_(f) static F_ f(STG_NO_ARGS)
-
-/* GCC is uncooperative about the next one: */
-/* But, the "extern" prevents initialisation... ADR */
-#if defined(__GNUC__)
-#define ID_(d) extern W_ d[]
-#define ID_RO_(d) extern const W_ d[] /* read-only */
-#else
-#define ID_(d) static W_ d[]
-#define ID_RO_(d) static const W_ d[] /* read-only */
-#endif /* not GCC */
-\end{code}
-
-General things; note: general-but-``machine-dependent'' macros are
-given in \tr{StgMachDeps.lh}.
-\begin{code}
-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
-word and split such a word back into two.
-
-Dependent on machine word size :-)
-*/
-
-#define COMBINE_WORDS(word,short1,short2) \
- do { \
- ((packed_shorts *)&(word))->wu.s1 = short1; \
- ((packed_shorts *)&(word))->wu.s2 = short2; \
- } while(0)
-
-#define SPLIT_WORD(word,short1,short2) \
- do { \
- short1 = ((packed_shorts *)&(word))->wu.s1; \
- short2 = ((packed_shorts *)&(word))->wu.s2; \
- } while(0)
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-gen-stg]{General STGish macros}
-%* *
-%************************************************************************
-
-Common sizes of vector-return tables.
-
-Claim: don't need fwd decls for return pts in \tr{VECTBL*}, because
-the AbsC flattener ensures that things come out sufficiently
-``backwards''.
-
-\begin{code}
-#ifdef __STG_REV_TBLS__
-#define UNVECTBL(staticp,label,a) /* nothing */
-#else
-#define UNVECTBL(staticp,label,a) \
-EXTFUN(a); \
-staticp const W_ label[] = { \
- (W_) a \
-};
-#endif
-\end{code}
-
-\begin{code}
-#if defined(USE_SPLIT_MARKERS)
-#define __STG_SPLIT_MARKER(n) FN_(CAT2(__stg_split_marker,n)){ }
-#else
-#define __STG_SPLIT_MARKER(n) /* nothing */
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[StgMacros-exceptions]{Exception-checking macros}
-%* *
-%************************************************************************
-
-Argument-satisfaction check, stack(s) overflow check, heap overflow
-check.
-
-The @SUBTRACT(upper, lower)@ macros return a positive result in words
-indicating the amount by which upper is above lower on the stack.
-
-\begin{code}
-#define SUBTRACT_A_STK( upper, lower ) AREL( (lower) - (upper) )
-#define SUBTRACT_B_STK( upper, lower ) BREL( (lower) - (upper) )
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-arg-satis]{Argument-satisfaction checks}
-%* *
-%************************************************************************
-
-@ARGS_CHK(n)@ sees of there are @n@ words of args on the A/B stack.
-If not, it jumps to @UpdatePAP@.
-
-@ARGS_CHK@ args are pre-directionified.
-Notice that we do the comparisons in the form (x < a+n), for
-some constant n. This generates more efficient code (with GCC at least)
-than (x-a < n).
-
-\begin{code}
-#define ARGS_CHK_A(n) \
- if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
- JMP_( UpdatePAP ); \
- }
-
-#define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
- if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
- Node = (P_) closure_addr; \
- JMP_( UpdatePAP ); \
- }
-
-#define ARGS_CHK_B(n) \
- if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
- JMP_( UpdatePAP ); \
- }
-
-
-#define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
- if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
- Node = (P_) closure_addr; \
- JMP_( UpdatePAP ); \
- }
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-stk-chks]{Stack-overflow check}
-%* *
-%************************************************************************
-
-@STK_CHK(a,b)@ [misc args omitted...] checks that we can allocate @a@
-words of A stack and @b@ words of B stack. If not, it calls
-@StackOverflow@ (which dies).
-
-(It will be different in the parallel case.)
-
-NB: args @a@ and @b@ are pre-direction-ified!
-\begin{code}
-I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
-int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
-
-#if ! defined(CONCURRENT)
-
-extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
-
-#if STACK_CHECK_BY_PAGE_FAULT
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- /* use memory protection instead; still need ticky-ness */
-
-#else
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- ULTRASAFESTGCALL0(void,(void *),StackOverflow)
-
-#endif /* not using page-faulting */
-
-#else /* threaded */
-
-I_ StackOverflow PROTO((W_, W_));
-
-/*
- * On a uniprocessor, we do *NOT* context switch on a stack overflow
- * (though we may GC). Therefore, we never have to reenter node.
- */
-
-#define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
- DO_STACKOVERFLOW((hda+hdb)<<2|((rtype)<<1)|(reenter),((spa)<<20)|((spb)<<8)|(liveness))
-
-#define STACK_OVERFLOW_HEADROOM(args,y) ((args) >> 2)
-#define STACK_OVERFLOW_PRIM_RETURN(args,y) ((args) & 2)
-#define STACK_OVERFLOW_REENTER(args,y) ((args) & 1)
-
-#define STACK_OVERFLOW_AWORDS(x,args) (((args) >> 20) & 0x0fff)
-#define STACK_OVERFLOW_BWORDS(x,args) (((args) >> 8) & 0x0fff)
-#define STACK_OVERFLOW_LIVENESS(x,args) ((args) & 0xff)
-
-#endif /* CONCURRENT */
-
-#define STK_CHK(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter)\
-do { \
- DO_ASTK_HWM(); /* ticky-ticky profiling */ \
- DO_BSTK_HWM(); \
- 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)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
-%* *
-%************************************************************************
-
-Please see the general discussion/commentary about ``what really
-happens in a GC,'' in \tr{SMinterface.lh}.
-
-\begin{code}
-void PerformGC PROTO((W_));
-void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_ always_reenter_node, rtsBool do_full_collection));
-void checkInCCallGC(STG_NO_ARGS);
-
-#ifndef PAR
-void StgPerformGarbageCollection(STG_NO_ARGS);
-#endif
-
-#ifndef CONCURRENT
-
-#define OR_MSG_PENDING /* never */
-
-#define HEAP_OVERFLOW(liveness,n,reenter) \
- do { \
- DO_GC((((W_)n)<<8)|(liveness)); \
- } while (0)
-
-#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
-#define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 8) & REQSIZE_BITMASK)
-#define HEAP_OVERFLOW_REENTER(args) 0
-#define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
-
-#else /* CONCURRENT */
-
-void ReallyPerformThreadGC PROTO((W_, rtsBool));
-
-#define HEAP_OVERFLOW(liveness,n,reenter) \
- do { \
- DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
- } while (0)
-
-#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
-#define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 9) & REQSIZE_BITMASK)
-#define HEAP_OVERFLOW_REENTER(args) (((args) >> 8) & 0x1)
-#define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
-
-#ifndef PAR
-
-#define OR_MSG_PENDING /* never */
-
-#else
-
-extern int PacketsWaiting; /*Probes for incoming messages*/
-extern int heapChkCounter; /*Not currently used! We check for messages when*/
- /*a thread is resheduled PWT*/
-/* #define OR_MSG_PENDING || (--heapChkCounter == 0 && PacketsWaiting())*/
-#define OR_MSG_PENDING /* never */
-
-#endif /* PAR */
-#endif /* CONCURRENT */
-
-#if 0 /* alpha_TARGET_ARCH */
-#define CACHE_LINE 4 /* words */
-#define LINES_AHEAD 3
-#define PRE_FETCH(n) \
-do { \
- StgInt j; \
- j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE]; \
-} while(0);
-#define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
-#else
-#define PRE_FETCH(reg)
-#define EXTRA_HEAP_WORDS 0
-#endif
-
-#if defined(GRAN)
-#define HEAP_CHK(liveness_mask,n,reenter) \
- do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- /* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
- ALLOC_HEAP(n); /* ticky profiling */ \
- GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
- if (((Hp = Hp + (n)) > HpLim)) { \
- /* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
- HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
- }}while(0)
-
-#else
-
-#define HEAP_CHK(liveness_mask,n,reenter) \
-do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- PRE_FETCH(n); \
- ALLOC_HEAP(n); /* ticky profiling */ \
- if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
- HEAP_OVERFLOW(liveness_mask,n,reenter); \
- } \
-} while(0)
-
-#endif /* GRAN */
-
-#ifdef CONCURRENT
-
-#define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
-do { \
- /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
- PRE_FETCH(n); \
- ALLOC_HEAP(n); /* ticky profiling */ \
- if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
- HEAP_OVERFLOW(liveness_mask,n,reenter); \
- n = TSO_ARG1(CurrentTSO); \
- }} while(0)
-
-#else
-
-#define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
- HEAP_CHK(liveness_mask,n,reenter)
-
-#endif
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[StgMacros-prim-ops]{Primitive operations}
-%* *
-%************************************************************************
-
-One thing to be {\em very careful about} with these macros that assign
-to results is that the assignment must come {\em last}. Some of the
-other arguments may be in terms of addressing modes that get clobbered
-by the assignment. (Dirty imperative programming RULES!)
-
-The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
-%* *
-%************************************************************************
-
-We cast the chars in case one of them is a literal (so C things work right
-even for 8-bit chars).
-\begin{code}
-#define gtCharZh(r,a,b) r=(I_)((a)> (b))
-#define geCharZh(r,a,b) r=(I_)((a)>=(b))
-#define eqCharZh(r,a,b) r=(I_)((a)==(b))
-#define neCharZh(r,a,b) r=(I_)((a)!=(b))
-#define ltCharZh(r,a,b) r=(I_)((a)< (b))
-#define leCharZh(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 eqWordZh(r,a,b) r=(I_)((a)==(b))
-#define neWordZh(r,a,b) r=(I_)((a)!=(b))
-#define ltWordZh(r,a,b) r=(I_)((a) <(b))
-#define leWordZh(r,a,b) r=(I_)((a)<=(b))
-
-#define gtAddrZh(r,a,b) r=(I_)((a) >(b))
-#define geAddrZh(r,a,b) r=(I_)((a)>=(b))
-#define eqAddrZh(r,a,b) r=(I_)((a)==(b))
-#define neAddrZh(r,a,b) r=(I_)((a)!=(b))
-#define ltAddrZh(r,a,b) r=(I_)((a) <(b))
-#define leAddrZh(r,a,b) r=(I_)((a)<=(b))
-
-#define gtFloatZh(r,a,b) r=(I_)((a)> (b))
-#define geFloatZh(r,a,b) r=(I_)((a)>=(b))
-#define eqFloatZh(r,a,b) r=(I_)((a)==(b))
-#define neFloatZh(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))
-
-/* 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}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
-%* *
-%************************************************************************
-
-We cast the chars in case one of them is a literal (so C things work right
-even for 8-bit chars).
-\begin{code}
-#define ordZh(r,a) r=(I_)((W_) (a))
-#define chrZh(r,a) r=(StgChar)((W_)(a))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-I_ stg_div PROTO((I_ a, I_ 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)
-/* 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}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
-%* *
-%************************************************************************
-
-\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 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}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define int2AddrZh(r,a) r=(A_)(a)
-#define addr2IntZh(r,a) r=(I_)(a)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#define plusFloatZh(r,a,b) r=(a)+(b)
-#define minusFloatZh(r,a,b) r=(a)-(b)
-#define timesFloatZh(r,a,b) r=(a)*(b)
-#define divideFloatZh(r,a,b) r=(a)/(b)
-#define negateFloatZh(r,a) r=-(a)
-
-#define int2FloatZh(r,a) r=(StgFloat)(a)
-#define float2IntZh(r,a) r=(I_)(a)
-
-#define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
-#define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
-#define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
-#define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
-#define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
-#define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
-#define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
-#define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
-#define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
-#define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
-#define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
-#define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-#define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
-
-/* encoding/decoding given w/ Integer stuff */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
-%* *
-%************************************************************************
-
-\begin{code}
-#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 double2IntZh(r,a) r=(I_)(a)
-
-#define float2DoubleZh(r,a) r=(StgDouble)(a)
-#define double2FloatZh(r,a) r=(StgFloat)(a)
-
-#define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
-#define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
-#define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
-#define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
-#define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
-#define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
-#define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
-#define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
-#define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,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)
-/* Power: **## */
-#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)}
-%* *
-%************************************************************************
-
-Dirty macros we use for the real business.
-
-INVARIANT: When one of these macros is called, the only live data is
-tidily on the STG stacks or in the STG registers (the code generator
-ensures this). If there are any pointer-arguments, they will be in
-the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
-
-OK, here are the real macros:
-\begin{code}
-#define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
-{ MP_INT arg; \
- MP_INT result; \
- I_ space = size_chk_macro(sa); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg.alloc = (aa); \
- arg.size = (sa); \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
- \
- /* Perform the operation */ \
- SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-
-
-#define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
-{ MP_INT arg1; \
- MP_INT arg2; \
- MP_INT result; \
- I_ space = size_chk_macro(s1,s2); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-
-#define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
-{ MP_INT arg1; \
- MP_INT arg2; \
- MP_INT result1; \
- MP_INT result2; \
- I_ space = size_chk_macro(s1,s2); \
- \
- /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
- GMP_HEAP_LOOKAHEAD(liveness,space); \
- \
- /* Now we can initialise (post possible GC) */ \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
- SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
- \
- /* Perform the operation */ \
- SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar1) = result1.alloc; \
- (sr1) = result1.size; \
- (dr1) = (B_) (result1.d - DATA_HS); \
- (ar2) = result2.alloc; \
- (sr2) = result2.size; \
- (dr2) = (B_) (result2.d - DATA_HS); \
-}
-\end{code}
-
-Some handy size-munging macros: sometimes gratuitously {\em conservative}.
-The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
-The \tr{__abs} stuff is because negative-ness of GMP things is encoded
-in their ``size''...
-\begin{code}
-#define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
-#define GMP_SIZE_ONE() (2 + DATA_HS + 16)
-#define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
-#define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
- /* NB: the +1 is for the carry (or whatever) */
-#define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
-#define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
- /* the +1 may just be paranoia */
-\end{code}
-
-For the Integer/GMP stuff, we have macros that {\em look ahead} for
-some space, but don't actually grab it.
-
-If there are live pointers at the time of the lookahead, the caller
-must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
-handled normally. We achieve this by having the code generator {\em
-always} pass args to may-invoke-GC primitives in registers, using the
-normal pointers-first policy. This means that, if we do go to garbage
-collection, everything is already in the Right Place.
-
-Saving and restoring Hp register so the MP allocator can see them. If we are
-performing liftime profiling need to save and restore HpLim as well so that
-it can be bumped if allocation occurs.
-
-The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
-it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
-threaded land.
-
-\begin{code}
-#define GMP_HEAP_LOOKAHEAD(liveness,n) \
- do { \
- HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
- Hp = Hp - (n); \
- UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
- SAVE_Hp = Hp; /* Hand over the hp */ \
- DEBUG_SetGMPAllocBudget(n) \
- }while(0)
-
-#define GMP_HEAP_HANDBACK() \
- Hp = SAVE_Hp; \
- DEBUG_ResetGMPAllocBudget()
-\end{code}
-
-\begin{code}
-void *stgAllocForGMP PROTO((size_t size_in_bytes));
-void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
-void stgDeallocForGMP PROTO((void *ptr, size_t size));
-
-#ifdef ALLOC_DEBUG
-extern StgInt DEBUG_GMPAllocBudget;
-#define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
-#define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
-#else
-#define DEBUG_SetGMPAllocBudget(n) /*nothing*/
-#define DEBUG_ResetGMPAllocBudget() /*nothing*/
-#endif
-\end{code}
-
-The real business (defining Integer primops):
-\begin{code}
-#define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
- gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
-
-#define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-#define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-#define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
-
-/* div, mod, quot, rem are defined w/ quotRem & divMod */
-
-#define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
-#define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
- gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
-\end{code}
-
-Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
-fellow (returns -ve, 0, or +ve).
-\begin{code}
-#define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
-{ MP_INT arg1; \
- MP_INT arg2; \
- /* Does not allocate memory */ \
- \
- arg1.alloc = (a1); \
- arg1.size = (s1); \
- arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
- arg2.alloc = (a2); \
- arg2.size = (s2); \
- arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
- \
- (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
-}
-\end{code}
-
-Coercions:
-
-\begin{code}
-#define integer2IntZh(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_si,&arg); \
-}
-
-/* Since we're forced to know a little bit about MP_INT layout to do this with
- pre-allocated heap, we just inline the whole of mpz_init_set_si here.
- ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
-*/
-
-#define int2IntegerZh(ar,sr,dr, hp, i) \
-{ StgInt val; /* to snaffle arg to avoid aliasing */ \
- \
- val = (i); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
- else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
- else /* val==0 */ { (sr) = 0; } \
- (ar) = 1; \
- (dr) = (B_)(hp); /* dr is an StgByteArray */ \
-}
-
-#define word2IntegerZh(ar,sr,dr, hp, i) \
-{ StgWord val; /* to snaffle arg to avoid aliasing */ \
- \
- val = (i); /* snaffle... */ \
- \
- SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- \
- if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
- else /* val==0 */ { (sr) = 0; } \
- (ar) = 1; \
- (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:
-\begin{code}
-/*
- DIRE WARNING.
- The "str" argument must be a literal C string.
-
- addr2Integer( ..., "foo") OK!
-
- x = "foo";
- addr2Integer( ..., x) NO! NO!
-*/
-
-#define addr2IntegerZh(ar,sr,dr, liveness, str) \
-{ MP_INT result; \
- /* taking the number of bytes/8 as the number of words of lookahead \
- is plenty conservative */ \
- I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
- \
- GMP_HEAP_LOOKAHEAD(liveness, space); \
- \
- /* Perform the operation */ \
- if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
- abort(); \
- \
- GMP_HEAP_HANDBACK(); /* restore Hp */ \
- (ar) = result.alloc; \
- (sr) = result.size; \
- (dr) = (B_) (result.d - DATA_HS); \
- /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
-}
-\end{code}
-
-Encoding and decoding float-ish things is pretty Integer-ish. We use
-these pretty magical support functions, essentially stolen from Lennart:
-\begin{code}
-StgFloat __encodeFloat PROTO((MP_INT *, I_));
-void __decodeFloat PROTO((MP_INT * /*result1*/,
- I_ * /*result2*/,
- StgFloat));
-
-StgDouble __encodeDouble PROTO((MP_INT *, I_));
-void __decodeDouble PROTO((MP_INT * /*result1*/,
- I_ * /*result2*/,
- StgDouble));
-\end{code}
-
-Some floating-point format info, made with the \tr{enquire} program
-(version~4.3) [comes with gcc].
-\begin{code}
-/* this should be done by CPU architecture, insofar as possible [WDP] */
-
-#if sparc_TARGET_ARCH \
- || alpha_TARGET_ARCH \
- || hppa1_1_TARGET_ARCH \
- || i386_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_TARGET_ARCH \
- || i386_TARGET_ARCH \
- || mipsel_TARGET_ARCH
-
-#undef BIGENDIAN /* little-endian weirdos... */
-#else
-#define BIGENDIAN 1
-#endif
-
-#else /* unknown floating-point format */
-
-******* ERROR *********** Any ideas about floating-point format?
-
-#endif /* unknown floating-point */
-\end{code}
-
-\begin{code}
-#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) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = aa; \
- arg.size = sa; \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
-}
-#endif /* ! alpha */
-
-#define encodeDoubleZh(r, hp, aa,sa,da, expon) \
-{ MP_INT arg; \
- /* Does not allocate memory */ \
- \
- arg.alloc = aa; \
- arg.size = sa; \
- arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
- \
- r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
-}
-
-#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) \
-{ MP_INT mantissa; \
- I_ exponent; \
- StgFloat arg = (f); \
- \
- /* Be prepared to tell Lennart-coded __decodeFloat */ \
- /* where mantissa.d can be put (it does not care about the rest) */ \
- SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- mantissa.d = (hp) + DATA_HS; \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
- exponr= exponent; \
- ar = mantissa.alloc; \
- sr = mantissa.size; \
- dr = (B_)(hp); \
-}
-#endif /* !alpha */
-
-#define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
-{ MP_INT mantissa; \
- I_ exponent; \
- StgDouble arg = (f); \
- \
- /* Be prepared to tell Lennart-coded __decodeDouble */ \
- /* where mantissa.d can be put (it does not care about the rest) */ \
- SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
- mantissa.d = (hp) + DATA_HS; \
- \
- /* Perform the operation */ \
- SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
- exponr= exponent; \
- ar = mantissa.alloc; \
- sr = mantissa.size; \
- dr = (B_)(hp); \
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
-%* *
-%************************************************************************
-
-With GCC, we use magic non-standard inlining; for other compilers, we
-just use functions (see also \tr{runtime/prims/PrimArith.lc}).
-
-(The @OMIT_...@ is only used in compiling some of the RTS, none of
-which uses these anyway.)
-
-\begin{code}
-#if alpha_TARGET_ARCH \
- || i386_TARGET_ARCH \
- || m68k_TARGET_ARCH
-
-#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
-#define PK_FLT(src) (*(StgFloat *)(src))
-
-#define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
-#define PK_DBL(src) (*(StgDouble *)(src))
-
-#else /* not m68k || alpha || i[34]86 */
-
-/* Special handling for machines with troublesome alignment constraints */
-
-#define FLOAT_ALIGNMENT_TROUBLES TRUE
-
-#if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
-
-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 */
-
-#if sparc_TARGET_ARCH
-
-#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
-#define PK_FLT(src) (*(StgFloat *)(src))
-
-#define ASSIGN_DBL(dst,src) \
- __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
- "=m" (((P_)(dst))[1]) : "f" (src));
-
-#define PK_DBL(src) \
- ( { register double d; \
- __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
- "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
- } )
-
-#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)
-{
- double_thing y;
- y.d = src;
- p_dest[0] = y.du.dhi;
- p_dest[1] = y.du.dlo;
-}
-
-/* GCC also works with this version, but it generates
- the same code as the previous one, and is not ANSI
-
-#define ASSIGN_DBL( p_dest, src ) \
- *p_dest = ((double_thing) src).du.dhi; \
- *(p_dest+1) = ((double_thing) src).du.dlo \
-*/
-
-extern STG_INLINE
-StgDouble
-PK_DBL(W_ p_src[])
-{
- double_thing y;
- y.du.dhi = p_src[0];
- y.du.dlo = p_src[1];
- return(y.d);
-}
-
-extern STG_INLINE
-void
-ASSIGN_FLT(W_ p_dest[], StgFloat src)
-{
- float_thing y;
- y.f = src;
- *p_dest = y.fu;
-}
-
-extern STG_INLINE
-StgFloat
-PK_FLT(W_ p_src[])
-{
- float_thing y;
- y.fu = *p_src;
- return(y.f);
-}
-
-#endif /* ! sparc */
-
-#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}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-array-primops]{Primitive arrays}
-%* *
-%************************************************************************
-
-We regularly use this macro to fish the ``contents'' part
-out of a DATA or TUPLE closure, which is what is used for
-non-ptr and ptr arrays (respectively).
-
-BYTE_ARR_CTS returns a @C_ *@!
-
-We {\em ASSUME} we can use the same macro for both!!
-\begin{code}
-
-#ifdef DEBUG
-#define BYTE_ARR_CTS(a) \
- ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
- ((C_ *) (((StgPtr) (a))+DATA_HS)); })
-#define PTRS_ARR_CTS(a) \
- ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
- || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
- ((a)+MUTUPLE_HS);} )
-#else
-#define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
-#define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
-#endif
-
-/* sigh */
-extern I_ genSymZh(STG_NO_ARGS);
-extern I_ resetGenSymZh(STG_NO_ARGS);
-extern I_ incSeqWorldZh(STG_NO_ARGS);
-
-extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
-\end{code}
-
-OK, the easy ops first: (all except \tr{newArr*}:
-
-(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 *}.
-
-In the case of @Array#@ (which contain pointers), the offset is in units
-of one ptr (not bytes).
-
-\begin{code}
-#define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
-#define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
-
-#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 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 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 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)
-
-
-/* Freezing arrays-of-ptrs requires changing an info table, for the
- benefit of the generational collector. It needs to scavenge mutable
- objects, even if they are in old space. When they become immutable,
- they can be removed from this scavenge list. */
-#define unsafeFreezeArrayZh(r,a) \
- do { \
- P_ result; \
- result=(P_) (a); \
- FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
- r = result; \
- }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:
-
-\begin{code}
-/*
---------------------
-Will: ToDo: we need to find suitable places to put this comment, and the
-"in-general" one which follows.
-
-************ Nota Bene. The "n" in this macro is guaranteed to
-be a register, *not* (say) Node[1]. That means that it is guaranteed
-to survive GC, provided only that the register is kept unaltered.
-This is important, because "n" is used after the HEAP_CHK.
-
-In general, *all* parameters to these primitive-op macros are always
-registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
-Exactly those which can trigger GC?)
-------------------------
-
-NOTE: the above may now be OLD (WDP 94/02/10)
-*/
-\end{code}
-
-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 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) \
-{ \
- P_ result; \
- I_ size; \
- \
- HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
- size = BYTES_TO_STGWORDS(n); \
- ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
- CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
- \
- result = Hp-(DATA_HS+size)+1; \
- SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
- r = (B_) result; \
-}
-\end{code}
-
-Arrays of pointers need to be initialised; uses \tr{TUPLES}!
-The initialisation value is guaranteed to be in a register,
-and will be indicated by the liveness mask, so it's ok to do
-a \tr{HEAP_CHK}, which may trigger GC.
-
-\begin{code}
-/* The new array initialization routine for the NCG */
-void newArrZh_init PROTO((P_ result, I_ n, P_ init));
-
-#define newArrayZh(r,liveness,n,init) \
-{ \
- P_ p; \
- P_ result; \
- \
- HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
- ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
- CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
- \
- result = Hp + 1 - (MUTUPLE_HS+(n)); \
- SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
- for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
- *p = (W_) (init); \
- } \
- \
- r = result; \
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
-%* *
-%************************************************************************
-
-\begin{code}
-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) = PrelBase_Z91Z93_closure; \
- r = hp; \
-}
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-void Yield PROTO((W_));
-
-#define takeMVarZh(r, liveness, node) \
-{ \
- while (INFO_PTR(node) != (W_) FullSVar_info) { \
- if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
- SVAR_HEAD(node) = CurrentTSO; \
- else \
- TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- 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) = PrelBase_Z91Z93_closure; \
-}
-
-#else
-
-#define takeMVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, EmptySVar_info); \
- r = SVAR_VALUE(node); \
- SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#ifdef GRAN
-
-/* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
-/* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
-/* the CurrentProc. This means we have an implicit context switch after */
-/* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
- tso = SVAR_HEAD(node); \
- 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 == PrelBase_Z91Z93_closure) \
- ThreadQueueHd = tso; \
- else \
- TSO_LINK(ThreadQueueTl) = tso; \
- ThreadQueueTl = tso; \
- SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
- } \
-}
-
-#else /* !GRAN */
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
- tso = SVAR_HEAD(node); \
- 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 == PrelBase_Z91Z93_closure) \
- RunnableThreadsHd = tso; \
- else \
- TSO_LINK(RunnableThreadsTl) = tso; \
- RunnableThreadsTl = tso; \
- SVAR_HEAD(node) = TSO_LINK(tso); \
- TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
- if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
- SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
- } \
-}
-
-#endif /* GRAN */
-
-#else
-
-#define putMVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) FullSVar_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "putMVar#: MVar already full.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- SET_INFO_PTR(node, FullSVar_info); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#define readIVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
- if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
- SVAR_HEAD(node) = CurrentTSO; \
- else \
- TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
- TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
- SVAR_TAIL(node) = CurrentTSO; \
- DO_YIELD(liveness << 1); \
- } \
- r = SVAR_VALUE(node); \
-}
-
-#else
-
-#define readIVarZh(r, liveness, node) \
-{ \
- if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "readIVar#: IVar is empty.\n"); \
- EXIT(EXIT_FAILURE); \
- } \
- r = SVAR_VALUE(node); \
-}
-
-#endif
-\end{code}
-
-\begin{code}
-#ifdef CONCURRENT
-
-#ifdef GRAN
-
-/* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
-/* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
-/* the CurrentProc. This means we have an implicit context switch after */
-/* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
- ThreadQueueHd = tso; \
- else \
- TSO_LINK(ThreadQueueTl) = tso; \
- 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); \
- } \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- ThreadQueueTl = tso; \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#else /* !GRAN */
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- tso = SVAR_HEAD(node); \
- if (tso != (P_) PrelBase_Z91Z93_closure) { \
- if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
- RunnableThreadsHd = tso; \
- else \
- TSO_LINK(RunnableThreadsTl) = tso; \
- 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); \
- } \
- if (DO_QP_PROF) \
- STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
- RunnableThreadsTl = tso; \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif /* GRAN */
-
-#else
-
-#define writeIVarZh(node, value) \
-{ \
- P_ tso; \
- if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
- /* Don't wrap the calls; we're done with STG land */\
- fflush(stdout); \
- fprintf(stderr, "writeIVar#: IVar already full.\n");\
- EXIT(EXIT_FAILURE); \
- } \
- /* Don't use freeze, since it's conditional on GC */ \
- SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
- MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
- SVAR_VALUE(node) = value; \
-}
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef CONCURRENT
-
-/* ToDo: for GRAN */
-
-#define delayZh(liveness, us) \
- { \
- if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
- WaitingThreadsHd = CurrentTSO; \
- else \
- TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
- WaitingThreadsTl = CurrentTSO; \
- TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
- TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
- DO_YIELD(liveness << 1); \
- }
-
-#else
-
-#define delayZh(liveness, us) \
- { \
- fflush(stdout); \
- fprintf(stderr, "delay#: unthreaded build.\n"); \
- EXIT(EXIT_FAILURE); \
- }
-
-#endif
-
-#ifdef CONCURRENT
-
-/* ToDo: something for GRAN */
-
-#define waitReadZh(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)); \
- DO_YIELD(liveness << 1); \
- }
-
-#else
-
-#define waitReadZh(liveness, fd) \
- { \
- fflush(stdout); \
- 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); \
- }
-
-#endif
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
-%* *
-%************************************************************************
-
-\begin{code}
-extern P_ TopClosure;
-EXTFUN(ErrorIO_innards);
-EXTFUN(__std_entry_error__);
-
-#define errorIOZh(a) \
- do { TopClosure=(a); \
- (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
- (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
- 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))
-#define stg_putc(c,stream) putc((c),((FILE *) (stream)))
-#else
-/* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
-#define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
-#define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
-#endif
-
-int initialize_virtual_timer(int us);
-int install_segv_handler(STG_NO_ARGS);
-int install_vtalrm_handler(STG_NO_ARGS);
-void initUserSignals(STG_NO_ARGS);
-void blockUserSignals(STG_NO_ARGS);
-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);)
-
-#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)
-#define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
-#else
-extern I_ sig_install PROTO((I_, I_));
-#define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
-#define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
-#define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
-#endif
-
-#define STG_SIG_DFL (-1)
-#define STG_SIG_IGN (-2)
-#define STG_SIG_ERR (-3)
-
-StgInt getErrorHandler(STG_NO_ARGS);
-#ifndef PAR
-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_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
-%* *
-%************************************************************************
-
-
-The type of these should be:
-
-\begin{verbatim}
-makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
-deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
-\end{verbatim}
-
-Since world-tokens are no longer explicitly passed around, the
-implementations have a few less arguments/results.
-
-The simpler one is @deRefStablePointer#@ (which is only a primop
-because it is more polymorphic than is allowed of a ccall).
-
-\begin{code}
-#ifdef PAR
-
-#define deRefStablePtrZh(ri,sp) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#else /* !PAR */
-
-extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
-
-#define deRefStablePtrZh(ri,sp) \
- ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
-\end{code}
-
-Declarations for other stable pointer operations.
-
-\begin{code}
-void freeStablePointer PROTO((I_ stablePtr));
-
-void enterStablePtr PROTO((StgStablePtr, StgFunPtr));
-void performIO PROTO((StgStablePtr));
-I_ enterInt PROTO((StgStablePtr));
-I_ enterFloat PROTO((StgStablePtr));
-P_ deRefStablePointer PROTO((StgStablePtr));
-IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
-IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
-IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
-IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
-
-EXTFUN(stopPerformIODirectReturn);
-EXTFUN(startPerformIO);
-EXTFUN(stopEnterIntDirectReturn);
-EXTFUN(startEnterInt);
-EXTFUN(stopEnterFloatDirectReturn);
-EXTFUN(startEnterFloat);
-
-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;)
-\end{code}
-
-Somewhat harder is @makeStablePointer#@ --- it is usually simple but
-if we're unlucky, it will have to allocate a new table and copy the
-old bit over. Since we might, very occasionally, have to call the
-garbage collector, this has to be a macro... sigh!
-
-NB @newSP@ is required because it is entirely possible that
-@stablePtr@ and @unstablePtr@ are aliases and so we can't do the
-assignment to @stablePtr@ until we've finished with @unstablePtr@.
-
-Another obscure piece of coding is the recalculation of the size of
-the table. We do this just in case Jim's threads decide they want to
-context switch---in which case any stack-allocated variables may get
-trashed. (If only there was a special heap check which didn't
-consider context switching...)
-
-\begin{code}
-#ifndef PAR
-
-/* Calculate SP Table size from number of pointers */
-#define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
-
-/* Calculate number of pointers in new table from number in old table:
- any strictly increasing expression will do here */
-#define CalcNewNoSPtrs( i ) ((i)*2 + 100)
-
-void enlargeSPTable PROTO((P_, P_));
-
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- EXTDATA_RO(StablePointerTable_info); \
- EXTDATA(UnusedSP); \
- StgStablePtr newSP; \
- \
- if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
- { /* Variables used before the heap check */ \
- I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
- I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
- I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
- HEAP_CHK(liveness, _FHS+NewSize, 0); \
- } \
- { /* Variables used after the heap check - same values */ \
- I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
- I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
- I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
- P_ SPTable = Hp + 1 - (_FHS + NewSize); \
- \
- CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
- SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
- SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
- StorageMgrInfo.StablePointerTable = SPTable; \
- } \
- } \
- \
- newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
- SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
- CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
- stablePtr = newSP; \
-} while (0)
-
-#else
-
-#define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
-do { \
- fflush(stdout); \
- fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
- EXIT(EXIT_FAILURE); \
-} while(0)
-
-#endif /* !PAR */
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
-%* *
-%************************************************************************
-
-The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
-can expect three parameters: the two arguments and a "register" to put
-the result into.
-
-Message to Will: This primop breaks referential transparency so badly
-you might want to leave it out. On the other hand, if you hide it
-away in an appropriate monad, it's perfectly safe. [ADR]
-
-Note that this primop is non-deterministic: different results can be
-obtained depending on just what the garbage collector (and code
-optimiser??) has done. However, we can guarantee that if two objects
-are pointer-equal, they have the same denotation --- the converse most
-certainly doesn't hold.
-
-ToDo ADR: The degree of non-determinism could be greatly reduced by
-following indirections.
-
-\begin{code}
-#define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
-%* *
-%************************************************************************
-
-Assuming local sparking in some form, we can now inline the spark request.
-
-We build a doubly-linked list in the heap, so that we can handle FIFO
-or LIFO scheduling as we please.
-
-Anything with tag >= 0 is in WHNF, so we discard it.
-
-\begin{code}
-#ifdef CONCURRENT
-
-ED_(PrelBase_Z91Z93_closure);
-ED_(True_closure);
-
-#if defined(GRAN)
-#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) \
-{ \
- sparkq result; \
- if (SHOULD_SPARK(node)) { \
- 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 = 1; /* return code for successful spark -- HWL */ \
-}
-
-#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)
-
-#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,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 */ \
- } else if (do_qp_prof) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
- } \
- 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)++; sparksCreated++
-#else
-#define COUNT_SPARK
-#endif
-
-/*
- Note that we must bump the required thread count NOW, rather
- than when the thread is actually created.
- */
-
-#define forkZh(r,liveness,node) \
-{ \
- while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
- DO_YIELD((liveness << 1) | 1); \
- COUNT_SPARK; \
- if (SHOULD_SPARK(node)) { \
- *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
- } else if (DO_QP_PROF) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
- } \
- required_thread_count++; \
- context_switch = 1; \
- r = 1; /* Should not be necessary */ \
-}
-
-#define parZh(r,node) \
-{ \
- COUNT_SPARK; \
- if (SHOULD_SPARK(node) && \
- PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
- *PendingSparksTl[ADVISORY_POOL]++ = (P_)(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.
-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
-of thin air (it's a point within this code block). Then we set RetReg
-to the special polymorphic return code for seq, load up Node with the
-closure to be evaluated, and we're off. When the eval returns to the
-polymorphic seq return point, the two words are popped off the B stack,
-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);
-
-#define seqZh(r,liveness,node) \
- ({ \
- __label__ cont; \
- /* 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; \
- Node = node; \
- ENT_VIA_NODE(); \
- InfoPtr = (D_)(INFO_PTR(Node)); \
- JMP_(ENTRY_CODE(InfoPtr)); \
- cont: \
- r = 1; /* Should be unnecessary */ \
- })
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMacros-foreign-objects]{Foreign Objects}
-%* *
-%************************************************************************
-
-[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) 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 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 eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
-StgInt eqStablePtr PROTO((StgStablePtr p1, StgStablePtr p2));
-
-#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 + 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; \
- \
- \
- /*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_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 { \
- fflush(stdout); \
- fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
- 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}
-
-
-End-of-file's multi-slurp protection:
-\begin{code}
-#endif /* ! STGMACROS_H */
-\end{code}
projects / ghc-hetmet.git / blobdiff