2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
4 \section[StgMacros]{C macros used in GHC-generated \tr{.hc} files}
11 %************************************************************************
13 \subsection[StgMacros-abbrev]{Abbreviatory(?) and general macros}
15 %************************************************************************
19 /* for function declarations */
20 #define STGFUN(f) F_ f(STG_NO_ARGS)
21 #define STATICFUN(f) static F_ f(STG_NO_ARGS)
23 /* for functions/data that are really external to this module */
24 #define EXTFUN(f) extern F_ f(STG_NO_ARGS)
25 #define EXTDATA(d) extern W_ d[]
26 #define EXTDATA_RO(d) extern const W_ d[] /* read-only */
28 /* for fwd decls to functions/data somewhere else in this module */
29 /* (identical for the mo') */
30 #define INTFUN(f) static F_ f(STG_NO_ARGS)
31 #define INTDATA(d) extern W_ d[]
32 #define INTDATA_RO(d) extern const W_ d[] /* read-only */
34 /* short forms of most of the above */
36 #define FN_(f) F_ f(STG_NO_ARGS)
37 #define IFN_(f) static F_ f(STG_NO_ARGS)
38 #define EF_(f) extern F_ f(STG_NO_ARGS)
39 #define ED_(d) extern W_ d[]
40 #define ED_RO_(d) extern const W_ d[] /* read-only */
41 #define IF_(f) static F_ f(STG_NO_ARGS)
43 /* GCC is uncooperative about the next one: */
44 /* But, the "extern" prevents initialisation... ADR */
46 #define ID_(d) extern W_ d[]
47 #define ID_RO_(d) extern const W_ d[] /* read-only */
49 #define ID_(d) static W_ d[]
50 #define ID_RO_(d) static const W_ d[] /* read-only */
54 General things; note: general-but-``machine-dependent'' macros are
55 given in \tr{StgMachDeps.lh}.
57 #define STG_MAX(a,b) (((a)>=(b)) ? (a) : (b))
60 Macros to combine two short words into a single
61 word and split such a word back into two.
63 Dependent on machine word size :-)
66 #define COMBINE_WORDS(word,short1,short2) \
68 ((packed_shorts *)&(word))->wu.s1 = short1; \
69 ((packed_shorts *)&(word))->wu.s2 = short2; \
72 #define SPLIT_WORD(word,short1,short2) \
74 short1 = ((packed_shorts *)&(word))->wu.s1; \
75 short2 = ((packed_shorts *)&(word))->wu.s2; \
80 %************************************************************************
82 \subsection[StgMacros-gen-stg]{General STGish macros}
84 %************************************************************************
86 Common sizes of vector-return tables.
88 Claim: don't need fwd decls for return pts in \tr{VECTBL*}, because
89 the AbsC flattener ensures that things come out sufficiently
93 #ifdef __STG_REV_TBLS__
94 #define UNVECTBL(staticp,label,a) /* nothing */
96 #define UNVECTBL(staticp,label,a) \
98 staticp const W_ label[] = { \
105 #if defined(USE_SPLIT_MARKERS)
106 #define __STG_SPLIT_MARKER(n) FN_(CAT2(__stg_split_marker,n)){ }
108 #define __STG_SPLIT_MARKER(n) /* nothing */
112 %************************************************************************
114 \subsection[StgMacros-exceptions]{Exception-checking macros}
116 %************************************************************************
118 Argument-satisfaction check, stack(s) overflow check, heap overflow
121 The @SUBTRACT(upper, lower)@ macros return a positive result in words
122 indicating the amount by which upper is above lower on the stack.
125 #define SUBTRACT_A_STK( upper, lower ) AREL( (lower) - (upper) )
126 #define SUBTRACT_B_STK( upper, lower ) BREL( (lower) - (upper) )
129 %************************************************************************
131 \subsubsection[StgMacros-arg-satis]{Argument-satisfaction checks}
133 %************************************************************************
135 @ARGS_CHK(n)@ sees of there are @n@ words of args on the A/B stack.
136 If not, it jumps to @UpdatePAP@.
138 @ARGS_CHK@ args are pre-directionified.
139 Notice that we do the comparisons in the form (x < a+n), for
140 some constant n. This generates more efficient code (with GCC at least)
144 #define ARGS_CHK_A(n) \
145 SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
146 if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
149 SET_ACTIVITY(ACT_TAILCALL)
151 #define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
152 SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
153 if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
154 Node = (P_) closure_addr; \
157 SET_ACTIVITY(ACT_TAILCALL)
160 #define ARGS_CHK_B(n) \
161 SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
162 if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
165 SET_ACTIVITY(ACT_TAILCALL)
168 #define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
169 SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
170 if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
171 Node = (P_) closure_addr; \
174 SET_ACTIVITY(ACT_TAILCALL)
178 %************************************************************************
180 \subsubsection[StgMacros-stk-chks]{Stack-overflow check}
182 %************************************************************************
184 @STK_CHK(a,b)@ [misc args omitted...] checks that we can allocate @a@
185 words of A stack and @b@ words of B stack. If not, it calls
186 @StackOverflow@ (which dies).
188 (It will be different in the parallel case.)
190 NB: args @a@ and @b@ are pre-direction-ified!
192 extern I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
194 #if ! defined(CONCURRENT)
196 extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
198 #if STACK_CHECK_BY_PAGE_FAULT
200 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
201 /* use memory protection instead; still need ticky-ness */
205 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
206 ULTRASAFESTGCALL0(void,(void *),StackOverflow)
208 #endif /* not using page-faulting */
212 extern I_ StackOverflow PROTO((W_, W_));
215 * On a uniprocessor, we do *NOT* context switch on a stack overflow
216 * (though we may GC). Therefore, we never have to reenter node.
219 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
220 DO_STACKOVERFLOW((hda+hdb)<<2|((rtype)<<1)|(reenter),((spa)<<20)|((spb)<<8)|(liveness))
222 #define STACK_OVERFLOW_HEADROOM(args,y) ((args) >> 2)
223 #define STACK_OVERFLOW_PRIM_RETURN(args,y) ((args) & 2)
224 #define STACK_OVERFLOW_REENTER(args,y) ((args) & 1)
226 #define STACK_OVERFLOW_AWORDS(x,args) (((args) >> 20) & 0x0fff)
227 #define STACK_OVERFLOW_BWORDS(x,args) (((args) >> 8) & 0x0fff)
228 #define STACK_OVERFLOW_LIVENESS(x,args) ((args) & 0xff)
230 #endif /* CONCURRENT */
232 #define STK_CHK(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter)\
234 DO_ASTK_HWM(); /* ticky-ticky profiling */ \
236 /* SET_ACTIVITY(ACT_STK_CHK); /? SPAT counting -- no, using page faulting */ \
237 if (STKS_OVERFLOW_OP((a_headroom) + 1, (b_headroom) + 1)) { \
238 STACK_OVERFLOW(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter);\
243 %************************************************************************
245 \subsubsection[StgMacros-arity-chks]{Arity checks (for debugging)}
247 %************************************************************************
249 This is a debugging feature. Each call to fast-entry-point code sets
250 @ExpectedArity@ to some value, and the callee then checks that the
251 value is as expected.
254 #if defined(__DO_ARITY_CHKS__)
256 extern I_ ExpectedArity;
257 extern void ArityError PROTO((I_)) STG_NORETURN;
259 #define SET_ARITY(n) do { ExpectedArity = (n); } while(0)
260 #define CHK_ARITY(n) \
262 if (ExpectedArity != (n)) { \
263 ULTRASAFESTGCALL1(void,(void *, I_),ArityError,n); \
266 #else /* ! __DO_ARITY_CHKS__: normal case */
268 #define SET_ARITY(n) /* nothing */
269 #define CHK_ARITY(n) /* nothing */
271 #endif /* ! __DO_ARITY_CHKS__ */
274 %************************************************************************
276 \subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
278 %************************************************************************
280 Please see the general discussion/commentary about ``what really
281 happens in a GC,'' in \tr{SMinterface.lh}.
284 extern void PerformGC PROTO((W_));
285 void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_ always_reenter_node, rtsBool do_full_collection));
286 void checkInCCallGC(STG_NO_ARGS);
289 void StgPerformGarbageCollection(STG_NO_ARGS);
294 #define OR_MSG_PENDING /* never */
296 #define HEAP_OVERFLOW(liveness,n,reenter) \
298 SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
299 DO_GC((((W_)n)<<8)|(liveness)); \
300 SET_ACTIVITY(ACT_GC_STOP); \
303 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
304 #define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 8) & REQSIZE_BITMASK)
305 #define HEAP_OVERFLOW_REENTER(args) 0
306 #define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
308 #else /* CONCURRENT */
310 extern void ReallyPerformThreadGC PROTO((W_, rtsBool));
312 #define HEAP_OVERFLOW(liveness,n,reenter) \
314 SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
315 DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
316 SET_ACTIVITY(ACT_GC_STOP); \
319 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
320 #define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 9) & REQSIZE_BITMASK)
321 #define HEAP_OVERFLOW_REENTER(args) (((args) >> 8) & 0x1)
322 #define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
326 #define OR_MSG_PENDING /* never */
330 extern int PacketsWaiting; /*Probes for incoming messages*/
331 extern int heapChkCounter; /*Not currently used! We check for messages when*/
332 /*a thread is resheduled PWT*/
333 /* #define OR_MSG_PENDING || (--heapChkCounter == 0 && PacketsWaiting())*/
334 #define OR_MSG_PENDING /* never */
337 #endif /* CONCURRENT */
339 #if 0 /* alpha_TARGET_ARCH */
340 #define CACHE_LINE 4 /* words */
341 #define LINES_AHEAD 3
342 #define PRE_FETCH(n) \
345 j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE]; \
347 #define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
349 #define PRE_FETCH(reg)
350 #define EXTRA_HEAP_WORDS 0
354 #define HEAP_CHK(liveness_mask,n,reenter) \
356 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
357 /* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
358 ALLOC_HEAP(n); /* ticky profiling */ \
359 GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
360 SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
361 if (((Hp = Hp + (n)) > HpLim)) { \
362 /* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
363 HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
365 SET_ACTIVITY(ACT_REDN); /* back to normal reduction */ \
370 #define HEAP_CHK(liveness_mask,n,reenter) \
372 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
374 ALLOC_HEAP(n); /* ticky profiling */ \
375 SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
376 if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
377 HEAP_OVERFLOW(liveness_mask,n,reenter); \
385 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
387 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
389 ALLOC_HEAP(n); /* ticky profiling */ \
390 SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
391 if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
392 HEAP_OVERFLOW(liveness_mask,n,reenter); \
393 n = TSO_ARG1(CurrentTSO); \
395 SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
400 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
401 HEAP_CHK(liveness_mask,n,reenter)
408 %************************************************************************
410 \subsection[StgMacros-prim-ops]{Primitive operations}
412 %************************************************************************
414 One thing to be {\em very careful about} with these macros that assign
415 to results is that the assignment must come {\em last}. Some of the
416 other arguments may be in terms of addressing modes that get clobbered
417 by the assignment. (Dirty imperative programming RULES!)
419 The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
421 %************************************************************************
423 \subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
425 %************************************************************************
427 We cast the chars in case one of them is a literal (so C things work right
428 even for 8-bit chars).
430 #define gtCharZh(r,a,b) r=(I_)((a)> (b))
431 #define geCharZh(r,a,b) r=(I_)((a)>=(b))
432 #define eqCharZh(r,a,b) r=(I_)((a)==(b))
433 #define neCharZh(r,a,b) r=(I_)((a)!=(b))
434 #define ltCharZh(r,a,b) r=(I_)((a)< (b))
435 #define leCharZh(r,a,b) r=(I_)((a)<=(b))
437 #define gtIntZh(r,a,b) r=(I_)((a) >(b))
438 #define geIntZh(r,a,b) r=(I_)((a)>=(b))
439 #define eqIntZh(r,a,b) r=(I_)((a)==(b))
440 #define neIntZh(r,a,b) r=(I_)((a)!=(b))
441 #define ltIntZh(r,a,b) r=(I_)((a) <(b))
442 #define leIntZh(r,a,b) r=(I_)((a)<=(b))
444 #define gtWordZh(r,a,b) r=(I_)((a) >(b))
445 #define geWordZh(r,a,b) r=(I_)((a)>=(b))
446 #define eqWordZh(r,a,b) r=(I_)((a)==(b))
447 #define neWordZh(r,a,b) r=(I_)((a)!=(b))
448 #define ltWordZh(r,a,b) r=(I_)((a) <(b))
449 #define leWordZh(r,a,b) r=(I_)((a)<=(b))
451 #define gtAddrZh(r,a,b) r=(I_)((a) >(b))
452 #define geAddrZh(r,a,b) r=(I_)((a)>=(b))
453 #define eqAddrZh(r,a,b) r=(I_)((a)==(b))
454 #define neAddrZh(r,a,b) r=(I_)((a)!=(b))
455 #define ltAddrZh(r,a,b) r=(I_)((a) <(b))
456 #define leAddrZh(r,a,b) r=(I_)((a)<=(b))
458 #define gtFloatZh(r,a,b) r=(I_)((a)> (b))
459 #define geFloatZh(r,a,b) r=(I_)((a)>=(b))
460 #define eqFloatZh(r,a,b) r=(I_)((a)==(b))
461 #define neFloatZh(r,a,b) r=(I_)((a)!=(b))
462 #define ltFloatZh(r,a,b) r=(I_)((a)< (b))
463 #define leFloatZh(r,a,b) r=(I_)((a)<=(b))
465 #define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
466 #define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
467 #define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
468 #define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
469 #define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
470 #define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
473 %************************************************************************
475 \subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
477 %************************************************************************
479 We cast the chars in case one of them is a literal (so C things work right
480 even for 8-bit chars).
482 #define ordZh(r,a) r=(I_)((W_) (a))
483 #define chrZh(r,a) r=(StgChar)((W_)(a))
486 %************************************************************************
488 \subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
490 %************************************************************************
493 I_ stg_div PROTO((I_ a, I_ b));
495 #define plusIntZh(r,a,b) r=(a)+(b)
496 #define minusIntZh(r,a,b) r=(a)-(b)
497 #define timesIntZh(r,a,b) r=(a)*(b)
498 #define quotIntZh(r,a,b) r=(a)/(b)
499 #define divIntZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
500 #define remIntZh(r,a,b) r=(a)%(b)
501 #define negateIntZh(r,a) r=-(a)
504 %************************************************************************
506 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
508 %************************************************************************
511 #define andZh(r,a,b) r=(a)&(b)
512 #define orZh(r,a,b) r=(a)|(b)
513 #define notZh(r,a) r=~(a)
515 #define shiftLZh(r,a,b) r=(a)<<(b)
516 #define shiftRAZh(r,a,b) r=(a)>>(b)
517 #define shiftRLZh(r,a,b) r=(a)>>(b)
518 #define iShiftLZh(r,a,b) r=(a)<<(b)
519 #define iShiftRAZh(r,a,b) r=(a)>>(b)
520 #define iShiftRLZh(r,a,b) r=(a)>>(b)
522 #define int2WordZh(r,a) r=(W_)(a)
523 #define word2IntZh(r,a) r=(I_)(a)
526 %************************************************************************
528 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
530 %************************************************************************
533 #define int2AddrZh(r,a) r=(A_)(a)
534 #define addr2IntZh(r,a) r=(I_)(a)
537 %************************************************************************
539 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
541 %************************************************************************
544 #define plusFloatZh(r,a,b) r=(a)+(b)
545 #define minusFloatZh(r,a,b) r=(a)-(b)
546 #define timesFloatZh(r,a,b) r=(a)*(b)
547 #define divideFloatZh(r,a,b) r=(a)/(b)
548 #define negateFloatZh(r,a) r=-(a)
550 #define int2FloatZh(r,a) r=(StgFloat)(a)
551 #define float2IntZh(r,a) r=(I_)(a)
553 #define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
554 #define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
555 #define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
556 #define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
557 #define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
558 #define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
559 #define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
560 #define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
561 #define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
562 #define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
563 #define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
564 #define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
565 #define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
567 /* encoding/decoding given w/ Integer stuff */
570 %************************************************************************
572 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
574 %************************************************************************
577 #define plusDoubleZh(r,a,b) r=(a)+(b)
578 #define minusDoubleZh(r,a,b) r=(a)-(b)
579 #define timesDoubleZh(r,a,b) r=(a)*(b)
580 #define divideDoubleZh(r,a,b) r=(a)/(b)
581 #define negateDoubleZh(r,a) r=-(a)
583 #define int2DoubleZh(r,a) r=(StgDouble)(a)
584 #define double2IntZh(r,a) r=(I_)(a)
586 #define float2DoubleZh(r,a) r=(StgDouble)(a)
587 #define double2FloatZh(r,a) r=(StgFloat)(a)
589 #define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
590 #define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
591 #define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
592 #define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
593 #define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
594 #define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
595 #define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
596 #define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
597 #define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
598 #define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
599 #define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
600 #define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
601 #define powerDoubleZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
604 %************************************************************************
606 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
608 %************************************************************************
610 Dirty macros we use for the real business.
612 INVARIANT: When one of these macros is called, the only live data is
613 tidily on the STG stacks or in the STG registers (the code generator
614 ensures this). If there are any pointer-arguments, they will be in
615 the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
617 OK, here are the real macros:
619 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
622 I_ space = size_chk_macro(sa); \
624 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
625 GMP_HEAP_LOOKAHEAD(liveness,space); \
627 /* Now we can initialise (post possible GC) */ \
630 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
632 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
634 /* Perform the operation */ \
635 SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
637 GMP_HEAP_HANDBACK(); /* restore Hp */ \
638 (ar) = result.alloc; \
639 (sr) = result.size; \
640 (dr) = (B_) (result.d - DATA_HS); \
641 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
645 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
649 I_ space = size_chk_macro(s1,s2); \
651 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
652 GMP_HEAP_LOOKAHEAD(liveness,space); \
654 /* Now we can initialise (post possible GC) */ \
657 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
660 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
662 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
664 /* Perform the operation */ \
665 SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
667 GMP_HEAP_HANDBACK(); /* restore Hp */ \
668 (ar) = result.alloc; \
669 (sr) = result.size; \
670 (dr) = (B_) (result.d - DATA_HS); \
671 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
674 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
679 I_ space = size_chk_macro(s1,s2); \
681 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
682 GMP_HEAP_LOOKAHEAD(liveness,space); \
684 /* Now we can initialise (post possible GC) */ \
687 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
690 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
692 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
693 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
695 /* Perform the operation */ \
696 SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
698 GMP_HEAP_HANDBACK(); /* restore Hp */ \
699 (ar1) = result1.alloc; \
700 (sr1) = result1.size; \
701 (dr1) = (B_) (result1.d - DATA_HS); \
702 (ar2) = result2.alloc; \
703 (sr2) = result2.size; \
704 (dr2) = (B_) (result2.d - DATA_HS); \
708 Some handy size-munging macros: sometimes gratuitously {\em conservative}.
709 The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
710 The \tr{__abs} stuff is because negative-ness of GMP things is encoded
713 #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
714 #define GMP_SIZE_ONE() (2 + DATA_HS + 16)
715 #define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
716 #define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
717 /* NB: the +1 is for the carry (or whatever) */
718 #define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
719 #define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
720 /* the +1 may just be paranoia */
723 For the Integer/GMP stuff, we have macros that {\em look ahead} for
724 some space, but don't actually grab it.
726 If there are live pointers at the time of the lookahead, the caller
727 must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
728 handled normally. We achieve this by having the code generator {\em
729 always} pass args to may-invoke-GC primitives in registers, using the
730 normal pointers-first policy. This means that, if we do go to garbage
731 collection, everything is already in the Right Place.
733 Saving and restoring Hp register so the MP allocator can see them. If we are
734 performing liftime profiling need to save and restore HpLim as well so that
735 it can be bumped if allocation occurs.
737 The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
738 it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
742 #define GMP_HEAP_LOOKAHEAD(liveness,n) \
744 HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
746 UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
747 SAVE_Hp = Hp; /* Hand over the hp */ \
748 DEBUG_SetGMPAllocBudget(n) \
749 OptSaveHpLimRegister() \
752 #define GMP_HEAP_HANDBACK() \
754 DEBUG_ResetGMPAllocBudget() \
755 OptRestoreHpLimRegister()
759 void *stgAllocForGMP PROTO((size_t size_in_bytes));
760 void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
761 void stgDeallocForGMP PROTO((void *ptr, size_t size));
764 extern StgInt DEBUG_GMPAllocBudget;
765 #define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
766 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
768 #define DEBUG_SetGMPAllocBudget(n) /*nothing*/
769 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
774 #if defined (LIFE_PROFILE)
776 #define OptSaveHpLimRegister() \
778 #define OptRestoreHpLimRegister() \
781 #else /* ! LIFE_PROFILE */
783 #define OptSaveHpLimRegister() /* nothing */
784 #define OptRestoreHpLimRegister() /* nothing */
786 #endif /* ! LIFE_PROFILE */
789 The real business (defining Integer primops):
791 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
792 gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
794 #define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
795 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
796 #define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
797 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
798 #define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
799 gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
801 /* div, mod, quot, rem are defined w/ quotRem & divMod */
803 #define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
804 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
805 #define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
806 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
809 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
810 fellow (returns -ve, 0, or +ve).
812 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
815 /* Does not allocate memory */ \
819 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
822 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
824 (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
831 #define integer2IntZh(r, hp, aa,sa,da) \
833 /* Does not allocate memory */ \
837 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
839 (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg); \
842 /* Since we're forced to know a little bit about MP_INT layout to do this with
843 pre-allocated heap, we just inline the whole of mpz_init_set_si here.
844 ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
847 #define int2IntegerZh(ar,sr,dr, hp, i) \
848 { StgInt val; /* to snaffle arg to avoid aliasing */ \
850 val = (i); /* snaffle... */ \
852 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
854 if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
855 else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
856 else /* val==0 */ { (sr) = 0; } \
858 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
861 #define word2IntegerZh(ar,sr,dr, hp, i) \
862 { StgWord val; /* to snaffle arg to avoid aliasing */ \
864 val = (i); /* snaffle... */ \
866 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
868 if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
869 else /* val==0 */ { (sr) = 0; } \
871 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
876 Then there are a few oddments to make life easier:
880 The "str" argument must be a literal C string.
882 addr2Integer( ..., "foo") OK!
885 addr2Integer( ..., x) NO! NO!
888 #define addr2IntegerZh(ar,sr,dr, liveness, str) \
890 /* taking the number of bytes/8 as the number of words of lookahead \
891 is plenty conservative */ \
892 I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
894 GMP_HEAP_LOOKAHEAD(liveness, space); \
896 /* Perform the operation */ \
897 if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
900 GMP_HEAP_HANDBACK(); /* restore Hp */ \
901 (ar) = result.alloc; \
902 (sr) = result.size; \
903 (dr) = (B_) (result.d - DATA_HS); \
904 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
908 Encoding and decoding float-ish things is pretty Integer-ish. We use
909 these pretty magical support functions, essentially stolen from Lennart:
911 StgFloat __encodeFloat PROTO((MP_INT *, I_));
912 void __decodeFloat PROTO((MP_INT * /*result1*/,
916 StgDouble __encodeDouble PROTO((MP_INT *, I_));
917 void __decodeDouble PROTO((MP_INT * /*result1*/,
922 Some floating-point format info, made with the \tr{enquire} program
923 (version~4.3) [comes with gcc].
925 /* this should be done by CPU architecture, insofar as possible [WDP] */
927 #if sparc_TARGET_ARCH \
928 || alpha_TARGET_ARCH \
929 || hppa1_1_TARGET_ARCH \
930 || i386_TARGET_ARCH \
931 || i486_TARGET_ARCH \
932 || m68k_TARGET_ARCH \
933 || mipsel_TARGET_ARCH \
934 || mipseb_TARGET_ARCH \
935 || rs6000_TARGET_ARCH
937 /* yes, it is IEEE floating point */
938 #include "ieee-flpt.h"
940 #if alpha_dec_osf1_TARGET \
941 || i386_TARGET_ARCH \
942 || i486_TARGET_ARCH \
943 || mipsel_TARGET_ARCH
945 #undef BIGENDIAN /* little-endian weirdos... */
950 #else /* unknown floating-point format */
952 ******* ERROR *********** Any ideas about floating-point format?
954 #endif /* unknown floating-point */
958 #if alpha_dec_osf1_TARGET
959 #define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
961 #define encodeFloatZh(r, hp, aa,sa,da, expon) \
963 /* Does not allocate memory */ \
967 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
969 r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
973 #define encodeDoubleZh(r, hp, aa,sa,da, expon) \
975 /* Does not allocate memory */ \
979 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
981 r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
984 #if alpha_dec_osf1_TARGET
985 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
987 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
990 StgFloat arg = (f); \
992 /* Be prepared to tell Lennart-coded __decodeFloat */ \
993 /* where mantissa.d can be put (it does not care about the rest) */ \
994 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
995 mantissa.d = (hp) + DATA_HS; \
997 /* Perform the operation */ \
998 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
1000 ar = mantissa.alloc; \
1001 sr = mantissa.size; \
1006 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
1007 { MP_INT mantissa; \
1009 StgDouble arg = (f); \
1011 /* Be prepared to tell Lennart-coded __decodeDouble */ \
1012 /* where mantissa.d can be put (it does not care about the rest) */ \
1013 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
1014 mantissa.d = (hp) + DATA_HS; \
1016 /* Perform the operation */ \
1017 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
1019 ar = mantissa.alloc; \
1020 sr = mantissa.size; \
1025 %************************************************************************
1027 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
1029 %************************************************************************
1031 With GCC, we use magic non-standard inlining; for other compilers, we
1032 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
1034 (The @OMIT_...@ is only used in compiling some of the RTS, none of
1035 which uses these anyway.)
1038 #if alpha_TARGET_ARCH \
1039 || i386_TARGET_ARCH \
1040 || i486_TARGET_ARCH \
1043 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1044 #define PK_FLT(src) (*(StgFloat *)(src))
1046 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
1047 #define PK_DBL(src) (*(StgDouble *)(src))
1049 #else /* not m68k || alpha || i[34]86 */
1051 /* Special handling for machines with troublesome alignment constraints */
1053 #define FLOAT_ALIGNMENT_TROUBLES TRUE
1055 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
1057 extern void ASSIGN_DBL PROTO((W_ [], StgDouble));
1058 extern StgDouble PK_DBL PROTO((W_ []));
1059 extern void ASSIGN_FLT PROTO((W_ [], StgFloat));
1060 extern StgFloat PK_FLT PROTO((W_ []));
1062 #else /* yes, its __GNUC__ && we really want them */
1064 #if sparc_TARGET_ARCH
1066 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1067 #define PK_FLT(src) (*(StgFloat *)(src))
1069 #define ASSIGN_DBL(dst,src) \
1070 __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1071 "=m" (((P_)(dst))[1]) : "f" (src));
1073 #define PK_DBL(src) \
1074 ( { register double d; \
1075 __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1076 "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1083 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1087 p_dest[0] = y.du.dhi;
1088 p_dest[1] = y.du.dlo;
1091 /* GCC also works with this version, but it generates
1092 the same code as the previous one, and is not ANSI
1094 #define ASSIGN_DBL( p_dest, src ) \
1095 *p_dest = ((double_thing) src).du.dhi; \
1096 *(p_dest+1) = ((double_thing) src).du.dlo \
1104 y.du.dhi = p_src[0];
1105 y.du.dlo = p_src[1];
1111 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1127 #endif /* ! sparc */
1129 #endif /* __GNUC__ */
1131 #endif /* not __m68k__ */
1134 %************************************************************************
1136 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1138 %************************************************************************
1140 We regularly use this macro to fish the ``contents'' part
1141 out of a DATA or TUPLE closure, which is what is used for
1142 non-ptr and ptr arrays (respectively).
1144 BYTE_ARR_CTS returns a @C_ *@!
1146 We {\em ASSUME} we can use the same macro for both!!
1150 #define BYTE_ARR_CTS(a) \
1151 ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
1152 ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1153 #define PTRS_ARR_CTS(a) \
1154 ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
1155 || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1156 ((a)+MUTUPLE_HS);} )
1158 #define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
1159 #define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
1163 extern I_ genSymZh(STG_NO_ARGS);
1164 extern I_ resetGenSymZh(STG_NO_ARGS);
1165 extern I_ incSeqWorldZh(STG_NO_ARGS);
1167 /* sigh again: without these some (notably "float") willnae work */
1168 extern I_ long2bytes__ PROTO((long, unsigned char *));
1169 extern I_ int2bytes__ PROTO((int, unsigned char *));
1170 extern I_ short2bytes__ PROTO((short, unsigned char *));
1171 extern I_ float2bytes__ PROTO((float, unsigned char *));
1172 extern I_ double2bytes__ PROTO((double, unsigned char *));
1174 /* these may not be necessary; and they create warnings (WDP) */
1175 extern I_ bytes2long__ PROTO((P_, I_ *));
1176 extern I_ bytes2int__ PROTO((P_, I_ *));
1177 extern I_ bytes2short__ PROTO((P_, I_ *));
1178 extern I_ bytes2float__ PROTO((P_, StgFloat *));
1179 extern I_ bytes2double__ PROTO((P_, StgDouble *));
1181 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1184 OK, the easy ops first: (all except \tr{newArr*}:
1186 VERY IMPORTANT! The read/write/index primitive ops
1187 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1188 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1189 This is because you might be trying to take apart a C struct, where
1190 the offset from the start of the struct isn't a multiple of the
1191 size of the thing you're getting. Hence the @(char *)@ casts.
1193 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1194 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1196 In the case of @Array#@ (which contain pointers), the offset is in units
1197 of one ptr (not bytes).
1200 #define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
1201 #define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
1203 #define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1205 #define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1206 #define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1207 #define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1208 #define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1209 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1211 /* result ("r") arg ignored in write macros! */
1212 #define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1214 #define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1215 #define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1216 #define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1217 #define writeFloatArrayZh(a,i,v) \
1218 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1219 #define writeDoubleArrayZh(a,i,v) \
1220 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1222 #define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1224 #define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1225 #define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1226 #define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1227 #define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1228 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1230 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
1231 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
1232 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
1233 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1234 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1236 /* Freezing arrays-of-ptrs requires changing an info table, for the
1237 benefit of the generational collector. It needs to scavenge mutable
1238 objects, even if they are in old space. When they become immutable,
1239 they can be removed from this scavenge list. */
1240 #define unsafeFreezeArrayZh(r,a) \
1244 FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
1248 #define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
1251 Now the \tr{newArr*} ops:
1255 --------------------
1256 Will: ToDo: we need to find suitable places to put this comment, and the
1257 "in-general" one which follows.
1259 ************ Nota Bene. The "n" in this macro is guaranteed to
1260 be a register, *not* (say) Node[1]. That means that it is guaranteed
1261 to survive GC, provided only that the register is kept unaltered.
1262 This is important, because "n" is used after the HEAP_CHK.
1264 In general, *all* parameters to these primitive-op macros are always
1265 registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
1266 Exactly those which can trigger GC?)
1267 ------------------------
1269 NOTE: the above may now be OLD (WDP 94/02/10)
1273 For char arrays, the size is in {\em BYTES}.
1276 #define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
1277 #define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
1278 #define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
1279 #define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
1280 #define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
1282 #define newByteArray(r,liveness,n) \
1287 HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
1288 size = BYTES_TO_STGWORDS(n); \
1289 ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
1290 CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
1292 result = Hp-(DATA_HS+size)+1; \
1293 SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
1298 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1299 The initialisation value is guaranteed to be in a register,
1300 and will be indicated by the liveness mask, so it's ok to do
1301 a \tr{HEAP_CHK}, which may trigger GC.
1304 /* The new array initialization routine for the NCG */
1305 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1307 #define newArrayZh(r,liveness,n,init) \
1312 HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
1313 ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1314 CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
1316 result = Hp + 1 - (MUTUPLE_HS+(n)); \
1317 SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1318 for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1321 SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
1327 %************************************************************************
1329 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1331 %************************************************************************
1336 #define newSynchVarZh(r, hp) \
1338 ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1339 CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \
1340 SET_SVAR_HDR(hp,EmptySVar_info,CCC); \
1341 SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Nil_closure; \
1349 extern void Yield PROTO((W_));
1351 #define takeMVarZh(r, liveness, node) \
1353 while (INFO_PTR(node) != (W_) FullSVar_info) { \
1354 if (SVAR_HEAD(node) == Nil_closure) \
1355 SVAR_HEAD(node) = CurrentTSO; \
1357 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1358 TSO_LINK(CurrentTSO) = (P_) Nil_closure; \
1359 SVAR_TAIL(node) = CurrentTSO; \
1360 DO_YIELD(liveness << 1); \
1362 SET_INFO_PTR(node, EmptySVar_info); \
1363 r = SVAR_VALUE(node); \
1364 SVAR_VALUE(node) = Nil_closure; \
1369 #define takeMVarZh(r, liveness, node) \
1371 if (INFO_PTR(node) != (W_) FullSVar_info) { \
1372 /* Don't wrap the calls; we're done with STG land */\
1374 fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
1375 EXIT(EXIT_FAILURE); \
1377 SET_INFO_PTR(node, EmptySVar_info); \
1378 r = SVAR_VALUE(node); \
1379 SVAR_VALUE(node) = Nil_closure; \
1390 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1391 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1392 /* the CurrentProc. This means we have an implicit context switch after */
1393 /* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1395 #define putMVarZh(node, value) \
1398 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1399 /* Don't wrap the calls; we're done with STG land */\
1401 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1402 EXIT(EXIT_FAILURE); \
1404 SET_INFO_PTR(node, FullSVar_info); \
1405 SVAR_VALUE(node) = value; \
1406 tso = SVAR_HEAD(node); \
1407 if (tso != (P_) Nil_closure) { \
1409 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1410 if (ThreadQueueHd == Nil_closure) \
1411 ThreadQueueHd = tso; \
1413 TSO_LINK(ThreadQueueTl) = tso; \
1414 ThreadQueueTl = tso; \
1415 SVAR_HEAD(node) = TSO_LINK(tso); \
1416 TSO_LINK(tso) = (P_) Nil_closure; \
1417 if(SVAR_HEAD(node) == (P_) Nil_closure) \
1418 SVAR_TAIL(node) = (P_) Nil_closure; \
1424 #define putMVarZh(node, value) \
1427 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1428 /* Don't wrap the calls; we're done with STG land */\
1430 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1431 EXIT(EXIT_FAILURE); \
1433 SET_INFO_PTR(node, FullSVar_info); \
1434 SVAR_VALUE(node) = value; \
1435 tso = SVAR_HEAD(node); \
1436 if (tso != (P_) Nil_closure) { \
1438 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1439 if (RunnableThreadsHd == Nil_closure) \
1440 RunnableThreadsHd = tso; \
1442 TSO_LINK(RunnableThreadsTl) = tso; \
1443 RunnableThreadsTl = tso; \
1444 SVAR_HEAD(node) = TSO_LINK(tso); \
1445 TSO_LINK(tso) = (P_) Nil_closure; \
1446 if(SVAR_HEAD(node) == (P_) Nil_closure) \
1447 SVAR_TAIL(node) = (P_) Nil_closure; \
1455 #define putMVarZh(node, value) \
1458 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1459 /* Don't wrap the calls; we're done with STG land */\
1461 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1462 EXIT(EXIT_FAILURE); \
1464 SET_INFO_PTR(node, FullSVar_info); \
1465 SVAR_VALUE(node) = value; \
1474 #define readIVarZh(r, liveness, node) \
1476 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1477 if (SVAR_HEAD(node) == Nil_closure) \
1478 SVAR_HEAD(node) = CurrentTSO; \
1480 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1481 TSO_LINK(CurrentTSO) = (P_) Nil_closure; \
1482 SVAR_TAIL(node) = CurrentTSO; \
1483 DO_YIELD(liveness << 1); \
1485 r = SVAR_VALUE(node); \
1490 #define readIVarZh(r, liveness, node) \
1492 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1493 /* Don't wrap the calls; we're done with STG land */\
1495 fprintf(stderr, "readIVar#: IVar is empty.\n"); \
1496 EXIT(EXIT_FAILURE); \
1498 r = SVAR_VALUE(node); \
1509 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1510 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1511 /* the CurrentProc. This means we have an implicit context switch after */
1512 /* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1514 #define writeIVarZh(node, value) \
1517 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1518 /* Don't wrap the calls; we're done with STG land */\
1520 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1521 EXIT(EXIT_FAILURE); \
1523 tso = SVAR_HEAD(node); \
1524 if (tso != (P_) Nil_closure) { \
1525 if (ThreadQueueHd == Nil_closure) \
1526 ThreadQueueHd = tso; \
1528 TSO_LINK(ThreadQueueTl) = tso; \
1529 while(TSO_LINK(tso) != Nil_closure) { \
1531 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1532 tso = TSO_LINK(tso); \
1535 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1536 ThreadQueueTl = tso; \
1538 /* Don't use freeze, since it's conditional on GC */ \
1539 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1540 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1541 SVAR_VALUE(node) = value; \
1546 #define writeIVarZh(node, value) \
1549 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1550 /* Don't wrap the calls; we're done with STG land */\
1552 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1553 EXIT(EXIT_FAILURE); \
1555 tso = SVAR_HEAD(node); \
1556 if (tso != (P_) Nil_closure) { \
1557 if (RunnableThreadsHd == Nil_closure) \
1558 RunnableThreadsHd = tso; \
1560 TSO_LINK(RunnableThreadsTl) = tso; \
1561 while(TSO_LINK(tso) != Nil_closure) { \
1563 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1564 tso = TSO_LINK(tso); \
1567 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1568 RunnableThreadsTl = tso; \
1570 /* Don't use freeze, since it's conditional on GC */ \
1571 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1572 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1573 SVAR_VALUE(node) = value; \
1580 #define writeIVarZh(node, value) \
1583 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1584 /* Don't wrap the calls; we're done with STG land */\
1586 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1587 EXIT(EXIT_FAILURE); \
1589 /* Don't use freeze, since it's conditional on GC */ \
1590 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1591 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1592 SVAR_VALUE(node) = value; \
1598 %************************************************************************
1600 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1602 %************************************************************************
1607 /* ToDo: for GRAN */
1609 #define delayZh(liveness, us) \
1611 if (WaitingThreadsTl == Nil_closure) \
1612 WaitingThreadsHd = CurrentTSO; \
1614 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1615 WaitingThreadsTl = CurrentTSO; \
1616 TSO_LINK(CurrentTSO) = Nil_closure; \
1617 TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1618 DO_YIELD(liveness << 1); \
1623 #define delayZh(liveness, us) \
1626 fprintf(stderr, "delay#: unthreaded build.\n"); \
1627 EXIT(EXIT_FAILURE); \
1634 /* ToDo: something for GRAN */
1636 #define waitZh(liveness, fd) \
1638 if (WaitingThreadsTl == Nil_closure) \
1639 WaitingThreadsHd = CurrentTSO; \
1641 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1642 WaitingThreadsTl = CurrentTSO; \
1643 TSO_LINK(CurrentTSO) = Nil_closure; \
1644 TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
1645 DO_YIELD(liveness << 1); \
1650 #define waitZh(liveness, fd) \
1653 fprintf(stderr, "wait#: unthreaded build.\n"); \
1654 EXIT(EXIT_FAILURE); \
1661 %************************************************************************
1663 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1665 %************************************************************************
1668 extern P_ TopClosure;
1669 EXTFUN(ErrorIO_innards);
1670 EXTFUN(__std_entry_error__);
1672 #define errorIOZh(a) \
1673 do { TopClosure=(a); \
1674 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1675 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1676 JMP_(ErrorIO_innards); \
1679 #if !defined(CALLER_SAVES_SYSTEM)
1680 /* can use the macros */
1681 #define stg_getc(stream) getc((FILE *) (stream))
1682 #define stg_putc(c,stream) putc((c),((FILE *) (stream)))
1684 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1685 #define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1686 #define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1689 int initialize_virtual_timer(int us);
1690 int install_segv_handler(STG_NO_ARGS);
1691 int install_vtalrm_handler(STG_NO_ARGS);
1692 void initUserSignals(STG_NO_ARGS);
1693 void blockUserSignals(STG_NO_ARGS);
1694 void unblockUserSignals(STG_NO_ARGS);
1695 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1696 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1698 #ifdef _POSIX_SOURCE
1699 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1700 #define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1701 #define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1702 #define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1704 extern I_ sig_install PROTO((I_, I_));
1705 #define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1706 #define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1707 #define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1710 #define STG_SIG_DFL (-1)
1711 #define STG_SIG_IGN (-2)
1712 #define STG_SIG_ERR (-3)
1714 StgInt getErrorHandler(STG_NO_ARGS);
1716 void raiseError PROTO((StgStablePtr handler));
1717 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1719 void decrementErrorCount(STG_NO_ARGS);
1721 #define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1722 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1725 %************************************************************************
1727 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1729 %************************************************************************
1732 The type of these should be:
1735 makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1736 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1739 Since world-tokens are no longer explicitly passed around, the
1740 implementations have a few less arguments/results.
1742 The simpler one is @deRefStablePointer#@ (which is only a primop
1743 because it is more polymorphic than is allowed of a ccall).
1748 #define deRefStablePtrZh(ri,sp) \
1751 fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1752 EXIT(EXIT_FAILURE); \
1757 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1759 #define deRefStablePtrZh(ri,sp) \
1760 ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1764 Declarations for other stable pointer operations.
1767 void freeStablePointer PROTO((I_ stablePtr));
1769 void enterStablePtr PROTO((StgStablePtr, StgFunPtr));
1770 void performIO PROTO((StgStablePtr));
1771 I_ enterInt PROTO((StgStablePtr));
1772 I_ enterFloat PROTO((StgStablePtr));
1773 P_ deRefStablePointer PROTO((StgStablePtr));
1774 IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
1775 IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
1776 IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
1777 IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
1778 IF_RTS(extern I_ noBlackHoles;)
1779 IF_RTS(extern I_ SM_word_stk_size;)
1781 EXTFUN(stopPerformIODirectReturn);
1782 EXTFUN(startPerformIO);
1783 EXTFUN(stopEnterIntDirectReturn);
1784 EXTFUN(startEnterInt);
1785 EXTFUN(stopEnterFloatDirectReturn);
1786 EXTFUN(startEnterFloat);
1788 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1792 IF_RTS(extern I_ ErrorIO_call_count;)
1795 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1796 if we're unlucky, it will have to allocate a new table and copy the
1797 old bit over. Since we might, very occasionally, have to call the
1798 garbage collector, this has to be a macro... sigh!
1800 NB @newSP@ is required because it is entirely possible that
1801 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1802 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1804 Another obscure piece of coding is the recalculation of the size of
1805 the table. We do this just in case Jim's threads decide they want to
1806 context switch---in which case any stack-allocated variables may get
1807 trashed. (If only there was a special heap check which didn't
1808 consider context switching...)
1813 /* Calculate SP Table size from number of pointers */
1814 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1816 /* Calculate number of pointers in new table from number in old table:
1817 any strictly increasing expression will do here */
1818 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1820 extern void enlargeSPTable PROTO((P_, P_));
1822 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1824 EXTDATA_RO(StablePointerTable_info); \
1825 EXTDATA(UnusedSP); \
1826 StgStablePtr newSP; \
1828 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1829 { /* Variables used before the heap check */ \
1830 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1831 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1832 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1833 HEAP_CHK(liveness, _FHS+NewSize, 0); \
1835 { /* Variables used after the heap check - same values */ \
1836 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1837 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1838 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1839 P_ SPTable = Hp + 1 - (_FHS + NewSize); \
1841 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
1842 SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1843 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
1844 StorageMgrInfo.StablePointerTable = SPTable; \
1848 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
1849 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1850 stablePtr = newSP; \
1855 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1858 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1859 EXIT(EXIT_FAILURE); \
1865 %************************************************************************
1867 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1869 %************************************************************************
1871 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1872 can expect three parameters: the two arguments and a "register" to put
1875 Message to Will: This primop breaks referential transparency so badly
1876 you might want to leave it out. On the other hand, if you hide it
1877 away in an appropriate monad, it's perfectly safe. [ADR]
1879 Note that this primop is non-deterministic: different results can be
1880 obtained depending on just what the garbage collector (and code
1881 optimiser??) has done. However, we can guarantee that if two objects
1882 are pointer-equal, they have the same denotation --- the converse most
1883 certainly doesn't hold.
1885 ToDo ADR: The degree of non-determinism could be greatly reduced by
1886 following indirections.
1889 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1892 %************************************************************************
1894 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1896 %************************************************************************
1898 Assuming local sparking in some form, we can now inline the spark request.
1900 We build a doubly-linked list in the heap, so that we can handle FIFO
1901 or LIFO scheduling as we please.
1903 Anything with tag >= 0 is in WHNF, so we discard it.
1912 #define parZh(r,hp,node,rest) \
1913 PARZh(r,hp,node,rest,0,0)
1915 #define parAtZh(r,hp,node,where,identifier,rest) \
1916 parATZh(r,hp,node,where,identifier,rest,1)
1918 #define parAtForNowZh(r,hp,node,where,identifier,rest) \
1919 parATZh(r,hp,node,where,identifier,rest,0)
1921 #define parATZh(r,hp,node,where,identifier,rest,local) \
1924 if (SHOULD_SPARK(node)) { \
1925 result = NewSpark((P_)node,identifier,local); \
1926 SAFESTGCALL3(void,(W_),GranSimSparkAt,result,where,identifier); \
1927 } else if (do_qp_prof) { \
1928 I_ tid = threadId++; \
1929 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1934 #define parLocalZh(r,hp,node,identifier,rest) \
1935 PARZh(r,hp,node,rest,identifier,1)
1937 #define parGlobalZh(r,hp,node,identifier,rest) \
1938 PARZh(r,hp,node,rest,identifier,0)
1940 #define PARZh(r,hp,node,rest,identifier,local) \
1943 if (SHOULD_SPARK(node)) { \
1944 result = NewSpark((P_)node,identifier,local); \
1945 ADD_TO_SPARK_QUEUE(result); \
1946 SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \
1947 /* context_switch = 1; not needed any more -- HWL */ \
1948 } else if (do_qp_prof) { \
1949 I_ tid = threadId++; \
1950 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1957 extern I_ required_thread_count;
1960 #define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++
1966 Note that we must bump the required thread count NOW, rather
1967 than when the thread is actually created.
1970 #define forkZh(r,liveness,node) \
1972 while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
1973 DO_YIELD((liveness << 1) | 1); \
1975 if (SHOULD_SPARK(node)) { \
1976 *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
1977 } else if (DO_QP_PROF) { \
1978 I_ tid = threadId++; \
1979 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1981 required_thread_count++; \
1982 context_switch = 1; \
1983 r = 1; /* Should not be necessary */ \
1986 #define parZh(r,node) \
1989 if (SHOULD_SPARK(node) && \
1990 PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
1991 *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
1992 } else if (DO_QP_PROF) { \
1993 I_ tid = threadId++; \
1994 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1996 r = 1; /* Should not be necessary */ \
2001 The following seq# code should only be used in unoptimized code.
2002 Be warned: it's a potential bug-farm.
2004 First we push two words on the B stack: the current value of RetReg
2005 (which may or may not be live), and a continuation snatched largely out
2006 of thin air (it's a point within this code block). Then we set RetReg
2007 to the special polymorphic return code for seq, load up Node with the
2008 closure to be evaluated, and we're off. When the eval returns to the
2009 polymorphic seq return point, the two words are popped off the B stack,
2010 RetReg is restored, and we jump to the continuation, completing the
2011 primop and going on our merry way.
2017 #define seqZh(r,liveness,node) \
2020 STK_CHK(liveness,0,2,0,0,0,0); \
2022 SpB[BREL(0)] = (W_) RetReg; \
2023 SpB[BREL(1)] = (W_) &&cont; \
2024 RetReg = (StgRetAddr) vtbl_seq; \
2027 InfoPtr = (D_)(INFO_PTR(Node)); \
2028 JMP_(ENTRY_CODE(InfoPtr)); \
2030 r = 1; /* Should be unnecessary */ \
2034 #endif /* CONCURRENT */
2037 %************************************************************************
2039 \subsubsection[StgMacros-malloc-ptrs]{Malloc Pointers}
2041 %************************************************************************
2043 This macro is used to construct a MallocPtr on the heap after a ccall.
2044 Since MallocPtr's are like arrays in many ways, this is heavily based
2045 on the stuff for arrays above.
2047 What this does is plug the pointer (which will be in a local
2048 variable), into a fresh heap object and then sets a result (which will
2049 be a register) to point to the fresh heap object.
2051 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2052 too? (It's if you want to use the SPAT profiling tools to
2053 characterize program behavior by ``activity'' -- tail-calling,
2054 heap-checking, etc. -- see RednCounts.lh. It is quite specialized.
2060 StgInt eqMallocPtr PROTO((StgMallocPtr p1, StgMallocPtr p2));
2061 void FreeMallocPtr PROTO((StgMallocPtr mp));
2063 #define constructMallocPtr(liveness, r, mptr) \
2067 HEAP_CHK(liveness, _FHS + MallocPtr_SIZE,0); \
2068 CC_ALLOC(CCC,_FHS + MallocPtr_SIZE,MallocPtr_K); /* cc prof */ \
2070 result = Hp + 1 - (_FHS + MallocPtr_SIZE); \
2071 SET_MallocPtr_HDR(result,MallocPtr_info,CCC,_FHS + MallocPtr_SIZE,0); \
2072 MallocPtr_CLOSURE_DATA(result) = mptr; \
2073 MallocPtr_CLOSURE_LINK(result) = StorageMgrInfo.MallocPtrList; \
2074 StorageMgrInfo.MallocPtrList = result; \
2077 printf("DEBUG: MallocPtr(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
2079 result[0],result[1], \
2080 result[2],result[3]); \
2082 CHECK_MallocPtr_CLOSURE( result ); \
2083 VALIDATE_MallocPtrList( StorageMgrInfo.MallocPtrList ); \
2085 (r) = (P_) result; \
2089 #define constructMallocPtr(liveness, r, mptr) \
2092 fprintf(stderr, "constructMallocPtr: no malloc pointer support.\n");\
2093 EXIT(EXIT_FAILURE); \
2100 End-of-file's multi-slurp protection:
2102 #endif /* ! STGMACROS_H */