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 I_ STG_MAX PROTO((I_, I_)); /* GCC -Wall loves prototypes */
61 STG_MAX(I_ a, I_ b) { return((a >= b) ? a : b); }
62 /* NB: the naive #define macro version of STG_MAX
63 can lead to exponential CPP explosion, if you
64 have very-nested STG_MAXes.
68 Macros to combine two short words into a single
69 word and split such a word back into two.
71 Dependent on machine word size :-)
74 #define COMBINE_WORDS(word,short1,short2) \
76 ((packed_shorts *)&(word))->wu.s1 = short1; \
77 ((packed_shorts *)&(word))->wu.s2 = short2; \
80 #define SPLIT_WORD(word,short1,short2) \
82 short1 = ((packed_shorts *)&(word))->wu.s1; \
83 short2 = ((packed_shorts *)&(word))->wu.s2; \
88 %************************************************************************
90 \subsection[StgMacros-gen-stg]{General STGish macros}
92 %************************************************************************
94 Common sizes of vector-return tables.
96 Claim: don't need fwd decls for return pts in \tr{VECTBL*}, because
97 the AbsC flattener ensures that things come out sufficiently
101 #ifdef __STG_REV_TBLS__
102 #define UNVECTBL(staticp,label,a) /* nothing */
104 #define UNVECTBL(staticp,label,a) \
106 staticp const W_ label[] = { \
113 #if defined(USE_SPLIT_MARKERS)
114 #define __STG_SPLIT_MARKER(n) FN_(CAT2(__stg_split_marker,n)){ }
116 #define __STG_SPLIT_MARKER(n) /* nothing */
120 %************************************************************************
122 \subsection[StgMacros-exceptions]{Exception-checking macros}
124 %************************************************************************
126 Argument-satisfaction check, stack(s) overflow check, heap overflow
129 The @SUBTRACT(upper, lower)@ macros return a positive result in words
130 indicating the amount by which upper is above lower on the stack.
133 #define SUBTRACT_A_STK( upper, lower ) AREL( (lower) - (upper) )
134 #define SUBTRACT_B_STK( upper, lower ) BREL( (lower) - (upper) )
137 %************************************************************************
139 \subsubsection[StgMacros-arg-satis]{Argument-satisfaction checks}
141 %************************************************************************
143 @ARGS_CHK(n)@ sees of there are @n@ words of args on the A/B stack.
144 If not, it jumps to @UpdatePAP@.
146 @ARGS_CHK@ args are pre-directionified.
147 Notice that we do the comparisons in the form (x < a+n), for
148 some constant n. This generates more efficient code (with GCC at least)
152 #define ARGS_CHK_A(n) \
153 if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
157 #define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
158 if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
159 Node = (P_) closure_addr; \
163 #define ARGS_CHK_B(n) \
164 if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
169 #define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
170 if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
171 Node = (P_) closure_addr; \
176 %************************************************************************
178 \subsubsection[StgMacros-stk-chks]{Stack-overflow check}
180 %************************************************************************
182 @STK_CHK(a,b)@ [misc args omitted...] checks that we can allocate @a@
183 words of A stack and @b@ words of B stack. If not, it calls
184 @StackOverflow@ (which dies).
186 (It will be different in the parallel case.)
188 NB: args @a@ and @b@ are pre-direction-ified!
190 I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
191 int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
193 #if ! defined(CONCURRENT)
195 extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
197 #if STACK_CHECK_BY_PAGE_FAULT
199 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
200 /* use memory protection instead; still need ticky-ness */
204 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
205 ULTRASAFESTGCALL0(void,(void *),StackOverflow)
207 #endif /* not using page-faulting */
211 I_ StackOverflow PROTO((W_, W_));
214 * On a uniprocessor, we do *NOT* context switch on a stack overflow
215 * (though we may GC). Therefore, we never have to reenter node.
218 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter) \
219 DO_STACKOVERFLOW((hda+hdb)<<2|((rtype)<<1)|(reenter),((spa)<<20)|((spb)<<8)|(liveness))
221 #define STACK_OVERFLOW_HEADROOM(args,y) ((args) >> 2)
222 #define STACK_OVERFLOW_PRIM_RETURN(args,y) ((args) & 2)
223 #define STACK_OVERFLOW_REENTER(args,y) ((args) & 1)
225 #define STACK_OVERFLOW_AWORDS(x,args) (((args) >> 20) & 0x0fff)
226 #define STACK_OVERFLOW_BWORDS(x,args) (((args) >> 8) & 0x0fff)
227 #define STACK_OVERFLOW_LIVENESS(x,args) ((args) & 0xff)
229 #endif /* CONCURRENT */
231 #define STK_CHK(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter)\
233 DO_ASTK_HWM(); /* ticky-ticky profiling */ \
235 if (STKS_OVERFLOW_OP(((a_headroom) + 1), ((b_headroom) + 1))) { \
236 STACK_OVERFLOW(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter);\
241 %************************************************************************
243 \subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
245 %************************************************************************
247 Please see the general discussion/commentary about ``what really
248 happens in a GC,'' in \tr{SMinterface.lh}.
251 void PerformGC PROTO((W_));
252 void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_ always_reenter_node, rtsBool do_full_collection));
253 void checkInCCallGC(STG_NO_ARGS);
256 void StgPerformGarbageCollection(STG_NO_ARGS);
261 #define OR_MSG_PENDING /* never */
263 #define HEAP_OVERFLOW(liveness,n,reenter) \
265 DO_GC((((W_)n)<<8)|(liveness)); \
268 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
269 #define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 8) & REQSIZE_BITMASK)
270 #define HEAP_OVERFLOW_REENTER(args) 0
271 #define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
273 #else /* CONCURRENT */
275 void ReallyPerformThreadGC PROTO((W_, rtsBool));
277 #define HEAP_OVERFLOW(liveness,n,reenter) \
279 DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
282 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
283 #define HEAP_OVERFLOW_REQSIZE(args) (((args) >> 9) & REQSIZE_BITMASK)
284 #define HEAP_OVERFLOW_REENTER(args) (((args) >> 8) & 0x1)
285 #define HEAP_OVERFLOW_LIVENESS(args) ((args) & 0xff)
289 #define OR_MSG_PENDING /* never */
293 extern int PacketsWaiting; /*Probes for incoming messages*/
294 extern int heapChkCounter; /*Not currently used! We check for messages when*/
295 /*a thread is resheduled PWT*/
296 /* #define OR_MSG_PENDING || (--heapChkCounter == 0 && PacketsWaiting())*/
297 #define OR_MSG_PENDING /* never */
300 #endif /* CONCURRENT */
302 #if 0 /* alpha_TARGET_ARCH */
303 #define CACHE_LINE 4 /* words */
304 #define LINES_AHEAD 3
305 #define PRE_FETCH(n) \
308 j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE]; \
310 #define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
312 #define PRE_FETCH(reg)
313 #define EXTRA_HEAP_WORDS 0
317 #define HEAP_CHK(liveness_mask,n,reenter) \
319 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
320 /* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
321 ALLOC_HEAP(n); /* ticky profiling */ \
322 GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
323 if (((Hp = Hp + (n)) > HpLim)) { \
324 /* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
325 HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
330 #define HEAP_CHK(liveness_mask,n,reenter) \
332 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
334 ALLOC_HEAP(n); /* ticky profiling */ \
335 if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
336 HEAP_OVERFLOW(liveness_mask,n,reenter); \
344 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
346 /* TICKY_PARANOIA(__FILE__, __LINE__); */ \
348 ALLOC_HEAP(n); /* ticky profiling */ \
349 if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
350 HEAP_OVERFLOW(liveness_mask,n,reenter); \
351 n = TSO_ARG1(CurrentTSO); \
356 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
357 HEAP_CHK(liveness_mask,n,reenter)
364 %************************************************************************
366 \subsection[StgMacros-prim-ops]{Primitive operations}
368 %************************************************************************
370 One thing to be {\em very careful about} with these macros that assign
371 to results is that the assignment must come {\em last}. Some of the
372 other arguments may be in terms of addressing modes that get clobbered
373 by the assignment. (Dirty imperative programming RULES!)
375 The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
377 %************************************************************************
379 \subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
381 %************************************************************************
383 We cast the chars in case one of them is a literal (so C things work right
384 even for 8-bit chars).
386 #define gtCharZh(r,a,b) r=(I_)((a)> (b))
387 #define geCharZh(r,a,b) r=(I_)((a)>=(b))
388 #define eqCharZh(r,a,b) r=(I_)((a)==(b))
389 #define neCharZh(r,a,b) r=(I_)((a)!=(b))
390 #define ltCharZh(r,a,b) r=(I_)((a)< (b))
391 #define leCharZh(r,a,b) r=(I_)((a)<=(b))
393 /* Int comparisons: >#, >=# etc */
394 #define ZgZh(r,a,b) r=(I_)((a) >(b))
395 #define ZgZeZh(r,a,b) r=(I_)((a)>=(b))
396 #define ZeZeZh(r,a,b) r=(I_)((a)==(b))
397 #define ZdZeZh(r,a,b) r=(I_)((a)!=(b))
398 #define ZlZh(r,a,b) r=(I_)((a) <(b))
399 #define ZlZeZh(r,a,b) r=(I_)((a)<=(b))
401 #define gtWordZh(r,a,b) r=(I_)((a) >(b))
402 #define geWordZh(r,a,b) r=(I_)((a)>=(b))
403 #define eqWordZh(r,a,b) r=(I_)((a)==(b))
404 #define neWordZh(r,a,b) r=(I_)((a)!=(b))
405 #define ltWordZh(r,a,b) r=(I_)((a) <(b))
406 #define leWordZh(r,a,b) r=(I_)((a)<=(b))
408 #define gtAddrZh(r,a,b) r=(I_)((a) >(b))
409 #define geAddrZh(r,a,b) r=(I_)((a)>=(b))
410 #define eqAddrZh(r,a,b) r=(I_)((a)==(b))
411 #define neAddrZh(r,a,b) r=(I_)((a)!=(b))
412 #define ltAddrZh(r,a,b) r=(I_)((a) <(b))
413 #define leAddrZh(r,a,b) r=(I_)((a)<=(b))
415 #define gtFloatZh(r,a,b) r=(I_)((a)> (b))
416 #define geFloatZh(r,a,b) r=(I_)((a)>=(b))
417 #define eqFloatZh(r,a,b) r=(I_)((a)==(b))
418 #define neFloatZh(r,a,b) r=(I_)((a)!=(b))
419 #define ltFloatZh(r,a,b) r=(I_)((a)< (b))
420 #define leFloatZh(r,a,b) r=(I_)((a)<=(b))
422 /* Double comparisons: >##, >=#@ etc */
423 #define ZgZhZh(r,a,b) r=(I_)((a) >(b))
424 #define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
425 #define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
426 #define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
427 #define ZlZhZh(r,a,b) r=(I_)((a) <(b))
428 #define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
431 %************************************************************************
433 \subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
435 %************************************************************************
437 We cast the chars in case one of them is a literal (so C things work right
438 even for 8-bit chars).
440 #define ordZh(r,a) r=(I_)((W_) (a))
441 #define chrZh(r,a) r=(StgChar)((W_)(a))
444 %************************************************************************
446 \subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
448 %************************************************************************
451 I_ stg_div PROTO((I_ a, I_ b));
453 #define ZpZh(r,a,b) r=(a)+(b)
454 #define ZmZh(r,a,b) r=(a)-(b)
455 #define ZtZh(r,a,b) r=(a)*(b)
456 #define quotIntZh(r,a,b) r=(a)/(b)
457 /* ZdZh not used??? --SDM */
458 #define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
459 #define remIntZh(r,a,b) r=(a)%(b)
460 #define negateIntZh(r,a) r=-(a)
461 /* Ever used ? -- SOF */
462 #define absIntZh(a) r=(( (a) >= 0 ) ? (a) : (-(a)))
465 %************************************************************************
467 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
469 %************************************************************************
472 #define quotWordZh(r,a,b) r=((W_)a)/((W_)b)
473 #define remWordZh(r,a,b) r=((W_)a)%((W_)b)
475 #define andZh(r,a,b) r=(a)&(b)
476 #define orZh(r,a,b) r=(a)|(b)
477 #define xorZh(r,a,b) r=(a)^(b)
478 #define notZh(r,a) r=~(a)
480 #define shiftLZh(r,a,b) r=(a)<<(b)
481 #define shiftRAZh(r,a,b) r=(a)>>(b)
482 #define shiftRLZh(r,a,b) r=(a)>>(b)
483 #define iShiftLZh(r,a,b) r=(a)<<(b)
484 #define iShiftRAZh(r,a,b) r=(a)>>(b)
485 #define iShiftRLZh(r,a,b) r=(a)>>(b)
487 #define int2WordZh(r,a) r=(W_)(a)
488 #define word2IntZh(r,a) r=(I_)(a)
491 %************************************************************************
493 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
495 %************************************************************************
498 #define int2AddrZh(r,a) r=(A_)(a)
499 #define addr2IntZh(r,a) r=(I_)(a)
502 %************************************************************************
504 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
506 %************************************************************************
509 #define plusFloatZh(r,a,b) r=(a)+(b)
510 #define minusFloatZh(r,a,b) r=(a)-(b)
511 #define timesFloatZh(r,a,b) r=(a)*(b)
512 #define divideFloatZh(r,a,b) r=(a)/(b)
513 #define negateFloatZh(r,a) r=-(a)
515 #define int2FloatZh(r,a) r=(StgFloat)(a)
516 #define float2IntZh(r,a) r=(I_)(a)
518 #define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
519 #define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
520 #define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
521 #define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
522 #define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
523 #define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
524 #define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
525 #define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
526 #define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
527 #define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
528 #define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
529 #define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
530 #define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
532 /* encoding/decoding given w/ Integer stuff */
535 %************************************************************************
537 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
539 %************************************************************************
542 #define ZpZhZh(r,a,b) r=(a)+(b)
543 #define ZmZhZh(r,a,b) r=(a)-(b)
544 #define ZtZhZh(r,a,b) r=(a)*(b)
545 #define ZdZhZh(r,a,b) r=(a)/(b)
546 #define negateDoubleZh(r,a) r=-(a)
548 #define int2DoubleZh(r,a) r=(StgDouble)(a)
549 #define double2IntZh(r,a) r=(I_)(a)
551 #define float2DoubleZh(r,a) r=(StgDouble)(a)
552 #define double2FloatZh(r,a) r=(StgFloat)(a)
554 #define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
555 #define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
556 #define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
557 #define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
558 #define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
559 #define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
560 #define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
561 #define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
562 #define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
563 #define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
564 #define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
565 #define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
567 #define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
570 %************************************************************************
572 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
574 %************************************************************************
576 Dirty macros we use for the real business.
578 INVARIANT: When one of these macros is called, the only live data is
579 tidily on the STG stacks or in the STG registers (the code generator
580 ensures this). If there are any pointer-arguments, they will be in
581 the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
583 OK, here are the real macros:
585 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
588 I_ space = size_chk_macro(sa); \
590 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
591 GMP_HEAP_LOOKAHEAD(liveness,space); \
593 /* Now we can initialise (post possible GC) */ \
596 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
598 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
600 /* Perform the operation */ \
601 SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
603 GMP_HEAP_HANDBACK(); /* restore Hp */ \
604 (ar) = result.alloc; \
605 (sr) = result.size; \
606 (dr) = (B_) (result.d - DATA_HS); \
607 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
611 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
615 I_ space = size_chk_macro(s1,s2); \
617 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
618 GMP_HEAP_LOOKAHEAD(liveness,space); \
620 /* Now we can initialise (post possible GC) */ \
623 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
626 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
628 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
630 /* Perform the operation */ \
631 SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
633 GMP_HEAP_HANDBACK(); /* restore Hp */ \
634 (ar) = result.alloc; \
635 (sr) = result.size; \
636 (dr) = (B_) (result.d - DATA_HS); \
637 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
640 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
645 I_ space = size_chk_macro(s1,s2); \
647 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
648 GMP_HEAP_LOOKAHEAD(liveness,space); \
650 /* Now we can initialise (post possible GC) */ \
653 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
656 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
658 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
659 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
661 /* Perform the operation */ \
662 SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
664 GMP_HEAP_HANDBACK(); /* restore Hp */ \
665 (ar1) = result1.alloc; \
666 (sr1) = result1.size; \
667 (dr1) = (B_) (result1.d - DATA_HS); \
668 (ar2) = result2.alloc; \
669 (sr2) = result2.size; \
670 (dr2) = (B_) (result2.d - DATA_HS); \
674 Some handy size-munging macros: sometimes gratuitously {\em conservative}.
675 The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
676 The \tr{__abs} stuff is because negative-ness of GMP things is encoded
679 #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
680 #define GMP_SIZE_ONE() (2 + DATA_HS + 16)
681 #define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
682 #define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
683 /* NB: the +1 is for the carry (or whatever) */
684 #define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
685 #define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
686 /* the +1 may just be paranoia */
689 For the Integer/GMP stuff, we have macros that {\em look ahead} for
690 some space, but don't actually grab it.
692 If there are live pointers at the time of the lookahead, the caller
693 must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
694 handled normally. We achieve this by having the code generator {\em
695 always} pass args to may-invoke-GC primitives in registers, using the
696 normal pointers-first policy. This means that, if we do go to garbage
697 collection, everything is already in the Right Place.
699 Saving and restoring Hp register so the MP allocator can see them. If we are
700 performing liftime profiling need to save and restore HpLim as well so that
701 it can be bumped if allocation occurs.
703 The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
704 it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
708 #define GMP_HEAP_LOOKAHEAD(liveness,n) \
710 HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
712 UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
713 SAVE_Hp = Hp; /* Hand over the hp */ \
714 DEBUG_SetGMPAllocBudget(n) \
717 #define GMP_HEAP_HANDBACK() \
719 DEBUG_ResetGMPAllocBudget()
723 void *stgAllocForGMP PROTO((size_t size_in_bytes));
724 void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
725 void stgDeallocForGMP PROTO((void *ptr, size_t size));
728 extern StgInt DEBUG_GMPAllocBudget;
729 #define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
730 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
732 #define DEBUG_SetGMPAllocBudget(n) /*nothing*/
733 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
737 The real business (defining Integer primops):
739 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
740 gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
742 #define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
743 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
744 #define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
745 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
746 #define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
747 gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
749 /* div, mod, quot, rem are defined w/ quotRem & divMod */
751 #define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
752 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
753 #define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
754 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
757 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
758 fellow (returns -ve, 0, or +ve).
760 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
763 /* Does not allocate memory */ \
767 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
770 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
772 (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
779 #define integer2IntZh(r, hp, aa,sa,da) \
781 /* Does not allocate memory */ \
785 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
787 (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg); \
790 /* Since we're forced to know a little bit about MP_INT layout to do this with
791 pre-allocated heap, we just inline the whole of mpz_init_set_si here.
792 ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
795 #define int2IntegerZh(ar,sr,dr, hp, i) \
796 { StgInt val; /* to snaffle arg to avoid aliasing */ \
798 val = (i); /* snaffle... */ \
800 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
802 if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
803 else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
804 else /* val==0 */ { (sr) = 0; } \
806 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
809 #define word2IntegerZh(ar,sr,dr, hp, i) \
810 { StgWord val; /* to snaffle arg to avoid aliasing */ \
812 val = (i); /* snaffle... */ \
814 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
816 if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
817 else /* val==0 */ { (sr) = 0; } \
819 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
822 #define integer2WordZh(r, hp, aa,sa,da) \
824 /* Does not allocate memory */ \
828 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
830 (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_ui,&arg); \
835 Then there are a few oddments to make life easier:
839 The "str" argument must be a literal C string.
841 addr2Integer( ..., "foo") OK!
844 addr2Integer( ..., x) NO! NO!
847 #define addr2IntegerZh(ar,sr,dr, liveness, str) \
849 /* taking the number of bytes/8 as the number of words of lookahead \
850 is plenty conservative */ \
851 I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
853 GMP_HEAP_LOOKAHEAD(liveness, space); \
855 /* Perform the operation */ \
856 if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
859 GMP_HEAP_HANDBACK(); /* restore Hp */ \
860 (ar) = result.alloc; \
861 (sr) = result.size; \
862 (dr) = (B_) (result.d - DATA_HS); \
863 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
867 Encoding and decoding float-ish things is pretty Integer-ish. We use
868 these pretty magical support functions, essentially stolen from Lennart:
870 StgFloat __encodeFloat PROTO((MP_INT *, I_));
871 void __decodeFloat PROTO((MP_INT * /*result1*/,
875 StgDouble __encodeDouble PROTO((MP_INT *, I_));
876 void __decodeDouble PROTO((MP_INT * /*result1*/,
881 Some floating-point format info, made with the \tr{enquire} program
882 (version~4.3) [comes with gcc].
884 /* this should be done by CPU architecture, insofar as possible [WDP] */
886 #if sparc_TARGET_ARCH \
887 || alpha_TARGET_ARCH \
888 || hppa1_1_TARGET_ARCH \
889 || i386_TARGET_ARCH \
890 || m68k_TARGET_ARCH \
891 || mipsel_TARGET_ARCH \
892 || mipseb_TARGET_ARCH \
893 || powerpc_TARGET_ARCH \
894 || rs6000_TARGET_ARCH
896 /* yes, it is IEEE floating point */
897 #include "ieee-flpt.h"
899 #if alpha_TARGET_ARCH \
900 || i386_TARGET_ARCH \
901 || mipsel_TARGET_ARCH
903 #undef BIGENDIAN /* little-endian weirdos... */
908 #else /* unknown floating-point format */
910 ******* ERROR *********** Any ideas about floating-point format?
912 #endif /* unknown floating-point */
916 #if alpha_TARGET_ARCH
917 #define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
919 #define encodeFloatZh(r, hp, aa,sa,da, expon) \
921 /* Does not allocate memory */ \
925 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
927 r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
931 #define encodeDoubleZh(r, hp, aa,sa,da, expon) \
933 /* Does not allocate memory */ \
937 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
939 r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
942 #if alpha_TARGET_ARCH
943 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
945 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
948 StgFloat arg = (f); \
950 /* Be prepared to tell Lennart-coded __decodeFloat */ \
951 /* where mantissa.d can be put (it does not care about the rest) */ \
952 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
953 mantissa.d = (hp) + DATA_HS; \
955 /* Perform the operation */ \
956 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
958 ar = mantissa.alloc; \
959 sr = mantissa.size; \
964 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
967 StgDouble arg = (f); \
969 /* Be prepared to tell Lennart-coded __decodeDouble */ \
970 /* where mantissa.d can be put (it does not care about the rest) */ \
971 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
972 mantissa.d = (hp) + DATA_HS; \
974 /* Perform the operation */ \
975 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
977 ar = mantissa.alloc; \
978 sr = mantissa.size; \
983 %************************************************************************
985 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
987 %************************************************************************
989 With GCC, we use magic non-standard inlining; for other compilers, we
990 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
992 (The @OMIT_...@ is only used in compiling some of the RTS, none of
993 which uses these anyway.)
996 #if alpha_TARGET_ARCH \
997 || i386_TARGET_ARCH \
1000 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1001 #define PK_FLT(src) (*(StgFloat *)(src))
1003 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
1004 #define PK_DBL(src) (*(StgDouble *)(src))
1006 #else /* not m68k || alpha || i[34]86 */
1008 /* Special handling for machines with troublesome alignment constraints */
1010 #define FLOAT_ALIGNMENT_TROUBLES TRUE
1012 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
1014 void ASSIGN_DBL PROTO((W_ [], StgDouble));
1015 StgDouble PK_DBL PROTO((W_ []));
1016 void ASSIGN_FLT PROTO((W_ [], StgFloat));
1017 StgFloat PK_FLT PROTO((W_ []));
1019 #else /* yes, its __GNUC__ && we really want them */
1021 #if sparc_TARGET_ARCH
1023 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1024 #define PK_FLT(src) (*(StgFloat *)(src))
1026 #define ASSIGN_DBL(dst,src) \
1027 __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1028 "=m" (((P_)(dst))[1]) : "f" (src));
1030 #define PK_DBL(src) \
1031 ( { register double d; \
1032 __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1033 "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1038 /* (not very) forward prototype declarations */
1039 void ASSIGN_DBL PROTO((W_ [], StgDouble));
1040 StgDouble PK_DBL PROTO((W_ []));
1041 void ASSIGN_FLT PROTO((W_ [], StgFloat));
1042 StgFloat PK_FLT PROTO((W_ []));
1046 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1050 p_dest[0] = y.du.dhi;
1051 p_dest[1] = y.du.dlo;
1054 /* GCC also works with this version, but it generates
1055 the same code as the previous one, and is not ANSI
1057 #define ASSIGN_DBL( p_dest, src ) \
1058 *p_dest = ((double_thing) src).du.dhi; \
1059 *(p_dest+1) = ((double_thing) src).du.dlo \
1067 y.du.dhi = p_src[0];
1068 y.du.dlo = p_src[1];
1074 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1090 #endif /* ! sparc */
1092 #endif /* __GNUC__ */
1094 #endif /* not __m68k__ */
1097 %************************************************************************
1099 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1101 %************************************************************************
1103 We regularly use this macro to fish the ``contents'' part
1104 out of a DATA or TUPLE closure, which is what is used for
1105 non-ptr and ptr arrays (respectively).
1107 BYTE_ARR_CTS returns a @C_ *@!
1109 We {\em ASSUME} we can use the same macro for both!!
1113 #define BYTE_ARR_CTS(a) \
1114 ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
1115 ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1116 #define PTRS_ARR_CTS(a) \
1117 ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
1118 || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1119 ((a)+MUTUPLE_HS);} )
1121 #define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
1122 #define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
1126 extern I_ genSymZh(STG_NO_ARGS);
1127 extern I_ resetGenSymZh(STG_NO_ARGS);
1128 extern I_ incSeqWorldZh(STG_NO_ARGS);
1130 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1133 OK, the easy ops first: (all except \tr{newArr*}:
1135 (OLD:) VERY IMPORTANT! The read/write/index primitive ops
1136 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1137 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1138 This is because you might be trying to take apart a C struct, where
1139 the offset from the start of the struct isn't a multiple of the
1140 size of the thing you're getting. Hence the @(char *)@ casts.
1142 EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
1143 are in Blahs. WDP 95/08
1145 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1146 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1148 In the case of @Array#@ (which contain pointers), the offset is in units
1149 of one ptr (not bytes).
1152 #define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
1153 #define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
1155 #define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1157 #define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1158 #define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1159 #define readWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
1160 #define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1161 #define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1162 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1164 /* result ("r") arg ignored in write macros! */
1165 #define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1167 #define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1168 #define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1169 #define writeWordArrayZh(a,i,v) ((W_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1170 #define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1171 #define writeFloatArrayZh(a,i,v) \
1172 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1173 #define writeDoubleArrayZh(a,i,v) \
1174 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1176 #define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1178 #define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1179 #define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1180 #define indexWordArrayZh(r,a,i) indexWordOffAddrZh(r,BYTE_ARR_CTS(a),i)
1181 #define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1182 #define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1183 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1185 #define indexCharOffForeignObjZh(r,fo,i) indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1186 #define indexIntOffForeignObjZh(r,fo,i) indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1187 #define indexWordOffForeignObjZh(r,fo,i) indexWordOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1188 #define indexAddrOffForeignObjZh(r,fo,i) indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1189 #define indexFloatOffForeignObjZh(r,fo,i) indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1190 #define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1192 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
1193 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
1194 #define indexWordOffAddrZh(r,a,i) r= ((W_ *)(a))[i]
1195 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
1196 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1197 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1199 /* Freezing arrays-of-ptrs requires changing an info table, for the
1200 benefit of the generational collector. It needs to scavenge mutable
1201 objects, even if they are in old space. When they become immutable,
1202 they can be removed from this scavenge list. */
1203 #define unsafeFreezeArrayZh(r,a) \
1207 FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
1211 #define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
1213 #define sizeofByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
1214 #define sizeofMutableByteArrayZh(r,a) r=(W_)sizeof(W_)*(W_)(DATA_CLOSURE_SIZE(a)-DATA_VHS)
1217 Now the \tr{newArr*} ops:
1221 --------------------
1222 Will: ToDo: we need to find suitable places to put this comment, and the
1223 "in-general" one which follows.
1225 ************ Nota Bene. The "n" in this macro is guaranteed to
1226 be a register, *not* (say) Node[1]. That means that it is guaranteed
1227 to survive GC, provided only that the register is kept unaltered.
1228 This is important, because "n" is used after the HEAP_CHK.
1230 In general, *all* parameters to these primitive-op macros are always
1231 registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
1232 Exactly those which can trigger GC?)
1233 ------------------------
1235 NOTE: the above may now be OLD (WDP 94/02/10)
1239 For char arrays, the size is in {\em BYTES}.
1242 #define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
1243 #define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
1244 #define newWordArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(W_))
1245 #define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
1246 #define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
1247 #define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
1249 #define newByteArray(r,liveness,n) \
1254 HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
1255 size = BYTES_TO_STGWORDS(n); \
1256 ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
1257 CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
1259 result = Hp-(DATA_HS+size)+1; \
1260 SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
1265 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1266 The initialisation value is guaranteed to be in a register,
1267 and will be indicated by the liveness mask, so it's ok to do
1268 a \tr{HEAP_CHK}, which may trigger GC.
1271 /* The new array initialization routine for the NCG */
1272 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1274 #define newArrayZh(r,liveness,n,init) \
1279 HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
1280 ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1281 CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
1283 result = Hp + 1 - (MUTUPLE_HS+(n)); \
1284 SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1285 for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1293 %************************************************************************
1295 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1297 %************************************************************************
1300 ED_(PrelBase_Z91Z93_closure);
1302 #define sameMVarZh(r,a,b) r=(I_)((a)==(b))
1304 #define newSynchVarZh(r, hp) \
1306 ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1307 CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \
1308 SET_SVAR_HDR(hp,EmptySVar_info,CCC); \
1309 SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = PrelBase_Z91Z93_closure; \
1317 void Yield PROTO((W_));
1319 #define takeMVarZh(r, liveness, node) \
1321 while (INFO_PTR(node) != (W_) FullSVar_info) { \
1322 if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
1323 SVAR_HEAD(node) = CurrentTSO; \
1325 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1326 TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
1327 SVAR_TAIL(node) = CurrentTSO; \
1328 DO_YIELD(liveness << 1); \
1330 SET_INFO_PTR(node, EmptySVar_info); \
1331 r = SVAR_VALUE(node); \
1332 SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
1337 #define takeMVarZh(r, liveness, node) \
1339 if (INFO_PTR(node) != (W_) FullSVar_info) { \
1340 /* Don't wrap the calls; we're done with STG land */\
1342 fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
1343 EXIT(EXIT_FAILURE); \
1345 SET_INFO_PTR(node, EmptySVar_info); \
1346 r = SVAR_VALUE(node); \
1347 SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
1358 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1359 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1360 /* the CurrentProc. This means we have an implicit context switch after */
1361 /* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1363 #define putMVarZh(node, value) \
1366 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1367 /* Don't wrap the calls; we're done with STG land */\
1369 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1370 EXIT(EXIT_FAILURE); \
1372 SET_INFO_PTR(node, FullSVar_info); \
1373 SVAR_VALUE(node) = value; \
1374 tso = SVAR_HEAD(node); \
1375 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1377 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1378 if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
1379 ThreadQueueHd = tso; \
1381 TSO_LINK(ThreadQueueTl) = tso; \
1382 ThreadQueueTl = tso; \
1383 SVAR_HEAD(node) = TSO_LINK(tso); \
1384 TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
1385 if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
1386 SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
1392 #define putMVarZh(node, value) \
1395 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1396 /* Don't wrap the calls; we're done with STG land */\
1398 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1399 EXIT(EXIT_FAILURE); \
1401 SET_INFO_PTR(node, FullSVar_info); \
1402 SVAR_VALUE(node) = value; \
1403 tso = SVAR_HEAD(node); \
1404 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1406 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1407 if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
1408 RunnableThreadsHd = tso; \
1410 TSO_LINK(RunnableThreadsTl) = tso; \
1411 RunnableThreadsTl = tso; \
1412 SVAR_HEAD(node) = TSO_LINK(tso); \
1413 TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
1414 if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
1415 SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
1423 #define putMVarZh(node, value) \
1426 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1427 /* Don't wrap the calls; we're done with STG land */\
1429 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1430 EXIT(EXIT_FAILURE); \
1432 SET_INFO_PTR(node, FullSVar_info); \
1433 SVAR_VALUE(node) = value; \
1442 #define readIVarZh(r, liveness, node) \
1444 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1445 if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
1446 SVAR_HEAD(node) = CurrentTSO; \
1448 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1449 TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
1450 SVAR_TAIL(node) = CurrentTSO; \
1451 DO_YIELD(liveness << 1); \
1453 r = SVAR_VALUE(node); \
1458 #define readIVarZh(r, liveness, node) \
1460 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1461 /* Don't wrap the calls; we're done with STG land */\
1463 fprintf(stderr, "readIVar#: IVar is empty.\n"); \
1464 EXIT(EXIT_FAILURE); \
1466 r = SVAR_VALUE(node); \
1477 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1478 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1479 /* the CurrentProc. This means we have an implicit context switch after */
1480 /* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1482 #define writeIVarZh(node, value) \
1485 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1486 /* Don't wrap the calls; we're done with STG land */\
1488 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1489 EXIT(EXIT_FAILURE); \
1491 tso = SVAR_HEAD(node); \
1492 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1493 if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
1494 ThreadQueueHd = tso; \
1496 TSO_LINK(ThreadQueueTl) = tso; \
1497 while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) { \
1499 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1500 tso = TSO_LINK(tso); \
1503 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1504 ThreadQueueTl = tso; \
1506 /* Don't use freeze, since it's conditional on GC */ \
1507 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1508 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1509 SVAR_VALUE(node) = value; \
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_) PrelBase_Z91Z93_closure) { \
1525 if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
1526 RunnableThreadsHd = tso; \
1528 TSO_LINK(RunnableThreadsTl) = tso; \
1529 while(TSO_LINK(tso) != PrelBase_Z91Z93_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 RunnableThreadsTl = 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; \
1548 #define writeIVarZh(node, value) \
1551 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1552 /* Don't wrap the calls; we're done with STG land */\
1554 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1555 EXIT(EXIT_FAILURE); \
1557 /* Don't use freeze, since it's conditional on GC */ \
1558 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1559 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1560 SVAR_VALUE(node) = value; \
1566 %************************************************************************
1568 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1570 %************************************************************************
1575 /* ToDo: for GRAN */
1577 #define delayZh(liveness, us) \
1579 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1580 WaitingThreadsHd = CurrentTSO; \
1582 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1583 WaitingThreadsTl = CurrentTSO; \
1584 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1585 TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1586 DO_YIELD(liveness << 1); \
1591 #define delayZh(liveness, us) \
1594 fprintf(stderr, "delay#: unthreaded build.\n"); \
1595 EXIT(EXIT_FAILURE); \
1602 /* ToDo: something for GRAN */
1604 #define waitReadZh(liveness, fd) \
1606 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1607 WaitingThreadsHd = CurrentTSO; \
1609 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1610 WaitingThreadsTl = CurrentTSO; \
1611 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1612 TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
1613 DO_YIELD(liveness << 1); \
1618 #define waitReadZh(liveness, fd) \
1621 fprintf(stderr, "waitRead#: unthreaded build.\n"); \
1622 EXIT(EXIT_FAILURE); \
1629 /* ToDo: something for GRAN */
1631 #ifdef HAVE_SYS_TYPES_H
1632 #include <sys/types.h>
1633 #endif HAVE_SYS_TYPES_H */
1635 #define waitWriteZh(liveness, fd) \
1637 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1638 WaitingThreadsHd = CurrentTSO; \
1640 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1641 WaitingThreadsTl = CurrentTSO; \
1642 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1643 TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
1644 DO_YIELD(liveness << 1); \
1649 #define waitWriteZh(liveness, fd) \
1652 fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1653 EXIT(EXIT_FAILURE); \
1660 %************************************************************************
1662 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1664 %************************************************************************
1667 extern P_ TopClosure;
1668 EXTFUN(ErrorIO_innards);
1669 EXTFUN(__std_entry_error__);
1671 #define errorIOZh(a) \
1672 do { TopClosure=(a); \
1673 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1674 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1675 JMP_(ErrorIO_innards); \
1678 #if !defined(CALLER_SAVES_SYSTEM)
1679 /* can use the macros */
1680 #define stg_getc(stream) getc((FILE *) (stream))
1681 #define stg_putc(c,stream) putc((c),((FILE *) (stream)))
1683 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1684 #define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1685 #define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1688 int initialize_virtual_timer(int us);
1689 int install_segv_handler(STG_NO_ARGS);
1690 int install_vtalrm_handler(STG_NO_ARGS);
1691 void initUserSignals(STG_NO_ARGS);
1692 void blockUserSignals(STG_NO_ARGS);
1693 void unblockUserSignals(STG_NO_ARGS);
1694 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1695 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1696 IF_RTS(void AwaitEvent(I_ delta);)
1698 #if defined(_POSIX_SOURCE) && !defined(nextstep3_TARGET_OS)
1699 /* For nextstep3_TARGET_OS comment see stgdefs.h. CaS */
1700 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1701 #define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1702 #define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1703 #define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1705 extern I_ sig_install PROTO((I_, I_));
1706 #define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1707 #define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1708 #define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1711 #define STG_SIG_DFL (-1)
1712 #define STG_SIG_IGN (-2)
1713 #define STG_SIG_ERR (-3)
1715 StgInt getErrorHandler(STG_NO_ARGS);
1717 void raiseError PROTO((StgStablePtr handler));
1718 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1720 void decrementErrorCount(STG_NO_ARGS);
1722 #define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1723 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1726 %************************************************************************
1728 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1730 %************************************************************************
1733 The type of these should be:
1736 makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1737 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1740 Since world-tokens are no longer explicitly passed around, the
1741 implementations have a few less arguments/results.
1743 The simpler one is @deRefStablePointer#@ (which is only a primop
1744 because it is more polymorphic than is allowed of a ccall).
1749 #define deRefStablePtrZh(ri,sp) \
1752 fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1753 EXIT(EXIT_FAILURE); \
1758 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1760 #define deRefStablePtrZh(ri,sp) \
1761 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);)
1779 EXTFUN(stopPerformIODirectReturn);
1780 EXTFUN(startPerformIO);
1781 EXTFUN(stopEnterIntDirectReturn);
1782 EXTFUN(startEnterInt);
1783 EXTFUN(stopEnterFloatDirectReturn);
1784 EXTFUN(startEnterFloat);
1786 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1790 IF_RTS(extern I_ ErrorIO_call_count;)
1793 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1794 if we're unlucky, it will have to allocate a new table and copy the
1795 old bit over. Since we might, very occasionally, have to call the
1796 garbage collector, this has to be a macro... sigh!
1798 NB @newSP@ is required because it is entirely possible that
1799 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1800 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1802 Another obscure piece of coding is the recalculation of the size of
1803 the table. We do this just in case Jim's threads decide they want to
1804 context switch---in which case any stack-allocated variables may get
1805 trashed. (If only there was a special heap check which didn't
1806 consider context switching...)
1811 /* Calculate SP Table size from number of pointers */
1812 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1814 /* Calculate number of pointers in new table from number in old table:
1815 any strictly increasing expression will do here */
1816 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1818 void enlargeSPTable PROTO((P_, P_));
1820 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1822 EXTDATA_RO(StablePointerTable_info); \
1823 EXTDATA(UnusedSP); \
1824 StgStablePtr newSP; \
1826 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1827 { /* Variables used before the heap check */ \
1828 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1829 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1830 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1831 HEAP_CHK(liveness, _FHS+NewSize, 0); \
1833 { /* Variables used after the heap check - same values */ \
1834 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1835 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1836 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1837 P_ SPTable = Hp + 1 - (_FHS + NewSize); \
1839 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
1840 SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1841 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
1842 StorageMgrInfo.StablePointerTable = SPTable; \
1846 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
1847 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1848 CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
1849 stablePtr = newSP; \
1854 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1857 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1858 EXIT(EXIT_FAILURE); \
1864 %************************************************************************
1866 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1868 %************************************************************************
1870 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1871 can expect three parameters: the two arguments and a "register" to put
1874 Message to Will: This primop breaks referential transparency so badly
1875 you might want to leave it out. On the other hand, if you hide it
1876 away in an appropriate monad, it's perfectly safe. [ADR]
1878 Note that this primop is non-deterministic: different results can be
1879 obtained depending on just what the garbage collector (and code
1880 optimiser??) has done. However, we can guarantee that if two objects
1881 are pointer-equal, they have the same denotation --- the converse most
1882 certainly doesn't hold.
1884 ToDo ADR: The degree of non-determinism could be greatly reduced by
1885 following indirections.
1888 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1891 %************************************************************************
1893 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1895 %************************************************************************
1897 Assuming local sparking in some form, we can now inline the spark request.
1899 We build a doubly-linked list in the heap, so that we can handle FIFO
1900 or LIFO scheduling as we please.
1902 Anything with tag >= 0 is in WHNF, so we discard it.
1907 ED_(PrelBase_Z91Z93_closure);
1911 #define parZh(r,node) \
1912 PARZh(r,node,1,0,0,0,0,0)
1914 #define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1915 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
1917 #define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1918 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
1920 #define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1921 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
1923 #define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1924 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
1926 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
1929 if (SHOULD_SPARK(node)) { \
1932 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local); \
1933 if (local==2) { /* special case for parAtAbs */ \
1934 GranSimSparkAtAbs(result,(I_)where,identifier);\
1935 } else if (local==3) { /* special case for parAtRel */ \
1936 GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier); \
1938 GranSimSparkAt(result,where,identifier); \
1940 context_switch = 1; \
1942 RestoreAllStgRegs(); \
1943 } else if (do_qp_prof) { \
1944 I_ tid = threadId++; \
1945 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1947 r = 1; /* return code for successful spark -- HWL */ \
1950 #define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1951 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
1953 #define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1954 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
1958 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1960 if (SHOULD_SPARK(node)) { \
1963 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1964 add_to_spark_queue(result); \
1965 GranSimSpark(local,(P_)node); \
1966 context_switch = 1; \
1968 RestoreAllStgRegs(); \
1969 } else if (do_qp_prof) { \
1970 I_ tid = threadId++; \
1971 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1973 r = 1; /* return code for successful spark -- HWL */ \
1978 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1981 if (SHOULD_SPARK(node)) { \
1982 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1983 ADD_TO_SPARK_QUEUE(result); \
1984 SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \
1985 /* context_switch = 1; not needed any more -- HWL */ \
1986 } else if (do_qp_prof) { \
1987 I_ tid = threadId++; \
1988 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1990 r = 1; /* return code for successful spark -- HWL */ \
1995 #define copyableZh(r,node) \
1996 /* copyable not yet implemented!! */
1998 #define noFollowZh(r,node) \
1999 /* noFollow not yet implemented!! */
2003 extern I_ required_thread_count;
2006 #define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++; sparksCreated++
2012 Note that we must bump the required thread count NOW, rather
2013 than when the thread is actually created.
2016 #define forkZh(r,liveness,node) \
2018 while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
2019 DO_YIELD((liveness << 1) | 1); \
2021 if (SHOULD_SPARK(node)) { \
2022 *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
2023 } else if (DO_QP_PROF) { \
2024 I_ tid = threadId++; \
2025 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
2027 required_thread_count++; \
2028 context_switch = 1; \
2029 r = 1; /* Should not be necessary */ \
2032 #define parZh(r,node) \
2035 if (SHOULD_SPARK(node) && \
2036 PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
2037 *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
2041 I_ tid = threadId++; \
2042 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
2045 r = 1; /* Should not be necessary */ \
2050 #endif /* CONCURRENT */
2053 The following seq# code should only be used in unoptimized code.
2054 Be warned: it's a potential bug-farm.
2056 First we push two words on the B stack: the current value of RetReg
2057 (which may or may not be live), and a continuation snatched largely out
2058 of thin air (it's a point within this code block). Then we set RetReg
2059 to the special polymorphic return code for seq, load up Node with the
2060 closure to be evaluated, and we're off. When the eval returns to the
2061 polymorphic seq return point, the two words are popped off the B stack,
2062 RetReg is restored, and we jump to the continuation, completing the
2063 primop and going on our merry way.
2069 #define seqZh(r,liveness,node) \
2072 /* STK_CHK(liveness,0,2,0,0,0,0); */ \
2073 /* SpB -= BREL(2); */ \
2074 SpB[BREL(0)] = (W_) RetReg; \
2075 SpB[BREL(1)] = (W_) &&cont; \
2076 RetReg = (StgRetAddr) vtbl_seq; \
2079 InfoPtr = (D_)(INFO_PTR(Node)); \
2080 JMP_(ENTRY_CODE(InfoPtr)); \
2082 r = 1; /* Should be unnecessary */ \
2087 %************************************************************************
2089 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2091 %************************************************************************
2093 [Based on previous MallocPtr comments -- SOF]
2095 This macro is used to construct a ForeignObj on the heap.
2097 What this does is plug the pointer (which will be in a local
2098 variable) together with its finalising/free routine, into a fresh heap
2099 object and then sets a result (which will be a register) to point
2100 to the fresh heap object.
2102 To accommodate per-object finalisation, augment the macro with a
2103 finalisation routine argument. Nothing spectacular, just plug the
2104 pointer to the routine into the ForeignObj -- SOF 4/96
2106 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2107 too? (It's if you want to use the SPAT profiling tools to
2108 characterize program behavior by ``activity'' -- tail-calling,
2109 heap-checking, etc. -- see Ticky.lh. It is quite specialized.
2112 (Swapped first two arguments to make it come into line with what appears
2113 to be `standard' format, return register then liveness mask. -- SOF 4/96)
2118 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2120 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2124 HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0); \
2125 CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */ \
2127 result = Hp + 1 - (_FHS + ForeignObj_SIZE); \
2128 SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
2129 ForeignObj_CLOSURE_DATA(result) = (P_)mptr; \
2130 ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise; \
2131 ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
2132 StorageMgrInfo.ForeignObjList = result; \
2135 /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
2137 result[0],result[1], \
2138 result[2],result[3]);*/ \
2140 CHECK_ForeignObj_CLOSURE( result ); \
2141 VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2143 (r) = (P_) result; \
2146 #define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
2149 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2152 fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2153 EXIT(EXIT_FAILURE); \
2156 #define writeForeignObjZh(res,datum) \
2159 fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
2160 EXIT(EXIT_FAILURE); \
2167 End-of-file's multi-slurp protection:
2169 #endif /* ! STGMACROS_H */