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 #define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
458 #define remIntZh(r,a,b) r=(a)%(b)
459 #define negateIntZh(r,a) r=-(a)
460 /* Ever used ? -- SOF */
461 #define absIntZh(a) r=(( (a) >= 0 ) ? (a) : (-(a)))
464 %************************************************************************
466 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
468 %************************************************************************
471 #define andZh(r,a,b) r=(a)&(b)
472 #define orZh(r,a,b) r=(a)|(b)
473 #define notZh(r,a) r=~(a)
475 #define shiftLZh(r,a,b) r=(a)<<(b)
476 #define shiftRAZh(r,a,b) r=(a)>>(b)
477 #define shiftRLZh(r,a,b) r=(a)>>(b)
478 #define iShiftLZh(r,a,b) r=(a)<<(b)
479 #define iShiftRAZh(r,a,b) r=(a)>>(b)
480 #define iShiftRLZh(r,a,b) r=(a)>>(b)
482 #define int2WordZh(r,a) r=(W_)(a)
483 #define word2IntZh(r,a) r=(I_)(a)
486 %************************************************************************
488 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
490 %************************************************************************
493 #define int2AddrZh(r,a) r=(A_)(a)
494 #define addr2IntZh(r,a) r=(I_)(a)
497 %************************************************************************
499 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
501 %************************************************************************
504 #define plusFloatZh(r,a,b) r=(a)+(b)
505 #define minusFloatZh(r,a,b) r=(a)-(b)
506 #define timesFloatZh(r,a,b) r=(a)*(b)
507 #define divideFloatZh(r,a,b) r=(a)/(b)
508 #define negateFloatZh(r,a) r=-(a)
510 #define int2FloatZh(r,a) r=(StgFloat)(a)
511 #define float2IntZh(r,a) r=(I_)(a)
513 #define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
514 #define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
515 #define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
516 #define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
517 #define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
518 #define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
519 #define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
520 #define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
521 #define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
522 #define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
523 #define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
524 #define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
525 #define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
527 /* encoding/decoding given w/ Integer stuff */
530 %************************************************************************
532 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
534 %************************************************************************
537 #define ZpZhZh(r,a,b) r=(a)+(b)
538 #define ZmZhZh(r,a,b) r=(a)-(b)
539 #define ZtZhZh(r,a,b) r=(a)*(b)
540 #define ZdZhZh(r,a,b) r=(a)/(b)
541 #define negateDoubleZh(r,a) r=-(a)
543 #define int2DoubleZh(r,a) r=(StgDouble)(a)
544 #define double2IntZh(r,a) r=(I_)(a)
546 #define float2DoubleZh(r,a) r=(StgDouble)(a)
547 #define double2FloatZh(r,a) r=(StgFloat)(a)
549 #define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
550 #define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
551 #define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
552 #define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
553 #define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
554 #define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
555 #define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
556 #define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
557 #define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
558 #define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
559 #define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
560 #define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
562 #define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
565 %************************************************************************
567 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
569 %************************************************************************
571 Dirty macros we use for the real business.
573 INVARIANT: When one of these macros is called, the only live data is
574 tidily on the STG stacks or in the STG registers (the code generator
575 ensures this). If there are any pointer-arguments, they will be in
576 the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
578 OK, here are the real macros:
580 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
583 I_ space = size_chk_macro(sa); \
585 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
586 GMP_HEAP_LOOKAHEAD(liveness,space); \
588 /* Now we can initialise (post possible GC) */ \
591 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
593 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
595 /* Perform the operation */ \
596 SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
598 GMP_HEAP_HANDBACK(); /* restore Hp */ \
599 (ar) = result.alloc; \
600 (sr) = result.size; \
601 (dr) = (B_) (result.d - DATA_HS); \
602 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
606 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
610 I_ space = size_chk_macro(s1,s2); \
612 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
613 GMP_HEAP_LOOKAHEAD(liveness,space); \
615 /* Now we can initialise (post possible GC) */ \
618 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
621 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
623 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
625 /* Perform the operation */ \
626 SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
628 GMP_HEAP_HANDBACK(); /* restore Hp */ \
629 (ar) = result.alloc; \
630 (sr) = result.size; \
631 (dr) = (B_) (result.d - DATA_HS); \
632 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
635 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
640 I_ space = size_chk_macro(s1,s2); \
642 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
643 GMP_HEAP_LOOKAHEAD(liveness,space); \
645 /* Now we can initialise (post possible GC) */ \
648 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
651 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
653 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
654 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
656 /* Perform the operation */ \
657 SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
659 GMP_HEAP_HANDBACK(); /* restore Hp */ \
660 (ar1) = result1.alloc; \
661 (sr1) = result1.size; \
662 (dr1) = (B_) (result1.d - DATA_HS); \
663 (ar2) = result2.alloc; \
664 (sr2) = result2.size; \
665 (dr2) = (B_) (result2.d - DATA_HS); \
669 Some handy size-munging macros: sometimes gratuitously {\em conservative}.
670 The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
671 The \tr{__abs} stuff is because negative-ness of GMP things is encoded
674 #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
675 #define GMP_SIZE_ONE() (2 + DATA_HS + 16)
676 #define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
677 #define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
678 /* NB: the +1 is for the carry (or whatever) */
679 #define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
680 #define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
681 /* the +1 may just be paranoia */
684 For the Integer/GMP stuff, we have macros that {\em look ahead} for
685 some space, but don't actually grab it.
687 If there are live pointers at the time of the lookahead, the caller
688 must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
689 handled normally. We achieve this by having the code generator {\em
690 always} pass args to may-invoke-GC primitives in registers, using the
691 normal pointers-first policy. This means that, if we do go to garbage
692 collection, everything is already in the Right Place.
694 Saving and restoring Hp register so the MP allocator can see them. If we are
695 performing liftime profiling need to save and restore HpLim as well so that
696 it can be bumped if allocation occurs.
698 The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
699 it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
703 #define GMP_HEAP_LOOKAHEAD(liveness,n) \
705 HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
707 UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
708 SAVE_Hp = Hp; /* Hand over the hp */ \
709 DEBUG_SetGMPAllocBudget(n) \
712 #define GMP_HEAP_HANDBACK() \
714 DEBUG_ResetGMPAllocBudget()
718 void *stgAllocForGMP PROTO((size_t size_in_bytes));
719 void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
720 void stgDeallocForGMP PROTO((void *ptr, size_t size));
723 extern StgInt DEBUG_GMPAllocBudget;
724 #define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
725 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
727 #define DEBUG_SetGMPAllocBudget(n) /*nothing*/
728 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
732 The real business (defining Integer primops):
734 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
735 gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
737 #define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
738 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
739 #define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
740 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
741 #define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
742 gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
744 /* div, mod, quot, rem are defined w/ quotRem & divMod */
746 #define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
747 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
748 #define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
749 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
752 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
753 fellow (returns -ve, 0, or +ve).
755 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
758 /* Does not allocate memory */ \
762 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
765 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
767 (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
774 #define integer2IntZh(r, hp, aa,sa,da) \
776 /* Does not allocate memory */ \
780 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
782 (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg); \
785 /* Since we're forced to know a little bit about MP_INT layout to do this with
786 pre-allocated heap, we just inline the whole of mpz_init_set_si here.
787 ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
790 #define int2IntegerZh(ar,sr,dr, hp, i) \
791 { StgInt val; /* to snaffle arg to avoid aliasing */ \
793 val = (i); /* snaffle... */ \
795 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
797 if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
798 else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
799 else /* val==0 */ { (sr) = 0; } \
801 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
804 #define word2IntegerZh(ar,sr,dr, hp, i) \
805 { StgWord val; /* to snaffle arg to avoid aliasing */ \
807 val = (i); /* snaffle... */ \
809 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
811 if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
812 else /* val==0 */ { (sr) = 0; } \
814 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
819 Then there are a few oddments to make life easier:
823 The "str" argument must be a literal C string.
825 addr2Integer( ..., "foo") OK!
828 addr2Integer( ..., x) NO! NO!
831 #define addr2IntegerZh(ar,sr,dr, liveness, str) \
833 /* taking the number of bytes/8 as the number of words of lookahead \
834 is plenty conservative */ \
835 I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
837 GMP_HEAP_LOOKAHEAD(liveness, space); \
839 /* Perform the operation */ \
840 if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
843 GMP_HEAP_HANDBACK(); /* restore Hp */ \
844 (ar) = result.alloc; \
845 (sr) = result.size; \
846 (dr) = (B_) (result.d - DATA_HS); \
847 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
851 Encoding and decoding float-ish things is pretty Integer-ish. We use
852 these pretty magical support functions, essentially stolen from Lennart:
854 StgFloat __encodeFloat PROTO((MP_INT *, I_));
855 void __decodeFloat PROTO((MP_INT * /*result1*/,
859 StgDouble __encodeDouble PROTO((MP_INT *, I_));
860 void __decodeDouble PROTO((MP_INT * /*result1*/,
865 Some floating-point format info, made with the \tr{enquire} program
866 (version~4.3) [comes with gcc].
868 /* this should be done by CPU architecture, insofar as possible [WDP] */
870 #if sparc_TARGET_ARCH \
871 || alpha_TARGET_ARCH \
872 || hppa1_1_TARGET_ARCH \
873 || i386_TARGET_ARCH \
874 || m68k_TARGET_ARCH \
875 || mipsel_TARGET_ARCH \
876 || mipseb_TARGET_ARCH \
877 || powerpc_TARGET_ARCH
879 /* yes, it is IEEE floating point */
880 #include "ieee-flpt.h"
882 #if alpha_dec_osf1_TARGET \
883 || i386_TARGET_ARCH \
884 || mipsel_TARGET_ARCH
886 #undef BIGENDIAN /* little-endian weirdos... */
891 #else /* unknown floating-point format */
893 ******* ERROR *********** Any ideas about floating-point format?
895 #endif /* unknown floating-point */
899 #if alpha_dec_osf1_TARGET
900 #define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
902 #define encodeFloatZh(r, hp, aa,sa,da, expon) \
904 /* Does not allocate memory */ \
908 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
910 r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
914 #define encodeDoubleZh(r, hp, aa,sa,da, expon) \
916 /* Does not allocate memory */ \
920 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
922 r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
925 #if alpha_dec_osf1_TARGET
926 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
928 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
931 StgFloat arg = (f); \
933 /* Be prepared to tell Lennart-coded __decodeFloat */ \
934 /* where mantissa.d can be put (it does not care about the rest) */ \
935 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
936 mantissa.d = (hp) + DATA_HS; \
938 /* Perform the operation */ \
939 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
941 ar = mantissa.alloc; \
942 sr = mantissa.size; \
947 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
950 StgDouble arg = (f); \
952 /* Be prepared to tell Lennart-coded __decodeDouble */ \
953 /* where mantissa.d can be put (it does not care about the rest) */ \
954 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
955 mantissa.d = (hp) + DATA_HS; \
957 /* Perform the operation */ \
958 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
960 ar = mantissa.alloc; \
961 sr = mantissa.size; \
966 %************************************************************************
968 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
970 %************************************************************************
972 With GCC, we use magic non-standard inlining; for other compilers, we
973 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
975 (The @OMIT_...@ is only used in compiling some of the RTS, none of
976 which uses these anyway.)
979 #if alpha_TARGET_ARCH \
980 || i386_TARGET_ARCH \
983 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
984 #define PK_FLT(src) (*(StgFloat *)(src))
986 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
987 #define PK_DBL(src) (*(StgDouble *)(src))
989 #else /* not m68k || alpha || i[34]86 */
991 /* Special handling for machines with troublesome alignment constraints */
993 #define FLOAT_ALIGNMENT_TROUBLES TRUE
995 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
997 void ASSIGN_DBL PROTO((W_ [], StgDouble));
998 StgDouble PK_DBL PROTO((W_ []));
999 void ASSIGN_FLT PROTO((W_ [], StgFloat));
1000 StgFloat PK_FLT PROTO((W_ []));
1002 #else /* yes, its __GNUC__ && we really want them */
1004 #if sparc_TARGET_ARCH
1006 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1007 #define PK_FLT(src) (*(StgFloat *)(src))
1009 #define ASSIGN_DBL(dst,src) \
1010 __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1011 "=m" (((P_)(dst))[1]) : "f" (src));
1013 #define PK_DBL(src) \
1014 ( { register double d; \
1015 __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1016 "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1021 /* (not very) forward prototype declarations */
1022 void ASSIGN_DBL PROTO((W_ [], StgDouble));
1023 StgDouble PK_DBL PROTO((W_ []));
1024 void ASSIGN_FLT PROTO((W_ [], StgFloat));
1025 StgFloat PK_FLT PROTO((W_ []));
1029 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1033 p_dest[0] = y.du.dhi;
1034 p_dest[1] = y.du.dlo;
1037 /* GCC also works with this version, but it generates
1038 the same code as the previous one, and is not ANSI
1040 #define ASSIGN_DBL( p_dest, src ) \
1041 *p_dest = ((double_thing) src).du.dhi; \
1042 *(p_dest+1) = ((double_thing) src).du.dlo \
1050 y.du.dhi = p_src[0];
1051 y.du.dlo = p_src[1];
1057 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1073 #endif /* ! sparc */
1075 #endif /* __GNUC__ */
1077 #endif /* not __m68k__ */
1080 %************************************************************************
1082 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1084 %************************************************************************
1086 We regularly use this macro to fish the ``contents'' part
1087 out of a DATA or TUPLE closure, which is what is used for
1088 non-ptr and ptr arrays (respectively).
1090 BYTE_ARR_CTS returns a @C_ *@!
1092 We {\em ASSUME} we can use the same macro for both!!
1096 #define BYTE_ARR_CTS(a) \
1097 ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
1098 ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1099 #define PTRS_ARR_CTS(a) \
1100 ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
1101 || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1102 ((a)+MUTUPLE_HS);} )
1104 #define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
1105 #define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
1109 extern I_ genSymZh(STG_NO_ARGS);
1110 extern I_ resetGenSymZh(STG_NO_ARGS);
1111 extern I_ incSeqWorldZh(STG_NO_ARGS);
1113 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1116 OK, the easy ops first: (all except \tr{newArr*}:
1118 (OLD:) VERY IMPORTANT! The read/write/index primitive ops
1119 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1120 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1121 This is because you might be trying to take apart a C struct, where
1122 the offset from the start of the struct isn't a multiple of the
1123 size of the thing you're getting. Hence the @(char *)@ casts.
1125 EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
1126 are in Blahs. WDP 95/08
1128 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1129 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1131 In the case of @Array#@ (which contain pointers), the offset is in units
1132 of one ptr (not bytes).
1135 #define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
1136 #define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
1138 #define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1140 #define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1141 #define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1142 #define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1143 #define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1144 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1146 /* result ("r") arg ignored in write macros! */
1147 #define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1149 #define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1150 #define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1151 #define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1152 #define writeFloatArrayZh(a,i,v) \
1153 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1154 #define writeDoubleArrayZh(a,i,v) \
1155 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1157 #define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1159 #define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1160 #define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1161 #define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1162 #define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1163 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1165 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
1166 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
1167 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
1168 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1169 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1171 /* Freezing arrays-of-ptrs requires changing an info table, for the
1172 benefit of the generational collector. It needs to scavenge mutable
1173 objects, even if they are in old space. When they become immutable,
1174 they can be removed from this scavenge list. */
1175 #define unsafeFreezeArrayZh(r,a) \
1179 FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
1183 #define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
1186 Now the \tr{newArr*} ops:
1190 --------------------
1191 Will: ToDo: we need to find suitable places to put this comment, and the
1192 "in-general" one which follows.
1194 ************ Nota Bene. The "n" in this macro is guaranteed to
1195 be a register, *not* (say) Node[1]. That means that it is guaranteed
1196 to survive GC, provided only that the register is kept unaltered.
1197 This is important, because "n" is used after the HEAP_CHK.
1199 In general, *all* parameters to these primitive-op macros are always
1200 registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
1201 Exactly those which can trigger GC?)
1202 ------------------------
1204 NOTE: the above may now be OLD (WDP 94/02/10)
1208 For char arrays, the size is in {\em BYTES}.
1211 #define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
1212 #define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
1213 #define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
1214 #define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
1215 #define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
1217 #define newByteArray(r,liveness,n) \
1222 HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
1223 size = BYTES_TO_STGWORDS(n); \
1224 ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
1225 CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
1227 result = Hp-(DATA_HS+size)+1; \
1228 SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
1233 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1234 The initialisation value is guaranteed to be in a register,
1235 and will be indicated by the liveness mask, so it's ok to do
1236 a \tr{HEAP_CHK}, which may trigger GC.
1239 /* The new array initialization routine for the NCG */
1240 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1242 #define newArrayZh(r,liveness,n,init) \
1247 HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
1248 ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1249 CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
1251 result = Hp + 1 - (MUTUPLE_HS+(n)); \
1252 SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1253 for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1261 %************************************************************************
1263 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1265 %************************************************************************
1268 ED_(PrelBase_Z91Z93_closure);
1270 #define newSynchVarZh(r, hp) \
1272 ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1273 CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \
1274 SET_SVAR_HDR(hp,EmptySVar_info,CCC); \
1275 SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = PrelBase_Z91Z93_closure; \
1283 void Yield PROTO((W_));
1285 #define takeMVarZh(r, liveness, node) \
1287 while (INFO_PTR(node) != (W_) FullSVar_info) { \
1288 if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
1289 SVAR_HEAD(node) = CurrentTSO; \
1291 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1292 TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
1293 SVAR_TAIL(node) = CurrentTSO; \
1294 DO_YIELD(liveness << 1); \
1296 SET_INFO_PTR(node, EmptySVar_info); \
1297 r = SVAR_VALUE(node); \
1298 SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
1303 #define takeMVarZh(r, liveness, node) \
1305 if (INFO_PTR(node) != (W_) FullSVar_info) { \
1306 /* Don't wrap the calls; we're done with STG land */\
1308 fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
1309 EXIT(EXIT_FAILURE); \
1311 SET_INFO_PTR(node, EmptySVar_info); \
1312 r = SVAR_VALUE(node); \
1313 SVAR_VALUE(node) = PrelBase_Z91Z93_closure; \
1324 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1325 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1326 /* the CurrentProc. This means we have an implicit context switch after */
1327 /* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1329 #define putMVarZh(node, value) \
1332 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1333 /* Don't wrap the calls; we're done with STG land */\
1335 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1336 EXIT(EXIT_FAILURE); \
1338 SET_INFO_PTR(node, FullSVar_info); \
1339 SVAR_VALUE(node) = value; \
1340 tso = SVAR_HEAD(node); \
1341 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1343 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1344 if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
1345 ThreadQueueHd = tso; \
1347 TSO_LINK(ThreadQueueTl) = tso; \
1348 ThreadQueueTl = tso; \
1349 SVAR_HEAD(node) = TSO_LINK(tso); \
1350 TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
1351 if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
1352 SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
1358 #define putMVarZh(node, value) \
1361 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1362 /* Don't wrap the calls; we're done with STG land */\
1364 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1365 EXIT(EXIT_FAILURE); \
1367 SET_INFO_PTR(node, FullSVar_info); \
1368 SVAR_VALUE(node) = value; \
1369 tso = SVAR_HEAD(node); \
1370 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1372 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1373 if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
1374 RunnableThreadsHd = tso; \
1376 TSO_LINK(RunnableThreadsTl) = tso; \
1377 RunnableThreadsTl = tso; \
1378 SVAR_HEAD(node) = TSO_LINK(tso); \
1379 TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure; \
1380 if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure) \
1381 SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure; \
1389 #define putMVarZh(node, value) \
1392 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1393 /* Don't wrap the calls; we're done with STG land */\
1395 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1396 EXIT(EXIT_FAILURE); \
1398 SET_INFO_PTR(node, FullSVar_info); \
1399 SVAR_VALUE(node) = value; \
1408 #define readIVarZh(r, liveness, node) \
1410 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1411 if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure) \
1412 SVAR_HEAD(node) = CurrentTSO; \
1414 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1415 TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure; \
1416 SVAR_TAIL(node) = CurrentTSO; \
1417 DO_YIELD(liveness << 1); \
1419 r = SVAR_VALUE(node); \
1424 #define readIVarZh(r, liveness, node) \
1426 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1427 /* Don't wrap the calls; we're done with STG land */\
1429 fprintf(stderr, "readIVar#: IVar is empty.\n"); \
1430 EXIT(EXIT_FAILURE); \
1432 r = SVAR_VALUE(node); \
1443 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1444 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1445 /* the CurrentProc. This means we have an implicit context switch after */
1446 /* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1448 #define writeIVarZh(node, value) \
1451 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1452 /* Don't wrap the calls; we're done with STG land */\
1454 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1455 EXIT(EXIT_FAILURE); \
1457 tso = SVAR_HEAD(node); \
1458 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1459 if (ThreadQueueHd == PrelBase_Z91Z93_closure) \
1460 ThreadQueueHd = tso; \
1462 TSO_LINK(ThreadQueueTl) = tso; \
1463 while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) { \
1465 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1466 tso = TSO_LINK(tso); \
1469 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1470 ThreadQueueTl = tso; \
1472 /* Don't use freeze, since it's conditional on GC */ \
1473 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1474 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1475 SVAR_VALUE(node) = value; \
1480 #define writeIVarZh(node, value) \
1483 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1484 /* Don't wrap the calls; we're done with STG land */\
1486 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1487 EXIT(EXIT_FAILURE); \
1489 tso = SVAR_HEAD(node); \
1490 if (tso != (P_) PrelBase_Z91Z93_closure) { \
1491 if (RunnableThreadsHd == PrelBase_Z91Z93_closure) \
1492 RunnableThreadsHd = tso; \
1494 TSO_LINK(RunnableThreadsTl) = tso; \
1495 while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) { \
1497 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1498 tso = TSO_LINK(tso); \
1501 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1502 RunnableThreadsTl = tso; \
1504 /* Don't use freeze, since it's conditional on GC */ \
1505 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1506 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1507 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 /* Don't use freeze, since it's conditional on GC */ \
1524 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1525 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1526 SVAR_VALUE(node) = value; \
1532 %************************************************************************
1534 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1536 %************************************************************************
1541 /* ToDo: for GRAN */
1543 #define delayZh(liveness, us) \
1545 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1546 WaitingThreadsHd = CurrentTSO; \
1548 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1549 WaitingThreadsTl = CurrentTSO; \
1550 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1551 TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1552 DO_YIELD(liveness << 1); \
1557 #define delayZh(liveness, us) \
1560 fprintf(stderr, "delay#: unthreaded build.\n"); \
1561 EXIT(EXIT_FAILURE); \
1568 /* ToDo: something for GRAN */
1570 #define waitReadZh(liveness, fd) \
1572 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1573 WaitingThreadsHd = CurrentTSO; \
1575 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1576 WaitingThreadsTl = CurrentTSO; \
1577 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1578 TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
1579 DO_YIELD(liveness << 1); \
1584 #define waitReadZh(liveness, fd) \
1587 fprintf(stderr, "waitRead#: unthreaded build.\n"); \
1588 EXIT(EXIT_FAILURE); \
1595 /* ToDo: something for GRAN */
1597 #ifdef HAVE_SYS_TYPES_H
1598 #include <sys/types.h>
1599 #endif HAVE_SYS_TYPES_H */
1601 #define waitWriteZh(liveness, fd) \
1603 if (WaitingThreadsTl == PrelBase_Z91Z93_closure) \
1604 WaitingThreadsHd = CurrentTSO; \
1606 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1607 WaitingThreadsTl = CurrentTSO; \
1608 TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure; \
1609 TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
1610 DO_YIELD(liveness << 1); \
1615 #define waitWriteZh(liveness, fd) \
1618 fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1619 EXIT(EXIT_FAILURE); \
1626 %************************************************************************
1628 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1630 %************************************************************************
1633 extern P_ TopClosure;
1634 EXTFUN(ErrorIO_innards);
1635 EXTFUN(__std_entry_error__);
1637 #define errorIOZh(a) \
1638 do { TopClosure=(a); \
1639 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1640 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1641 JMP_(ErrorIO_innards); \
1644 #if !defined(CALLER_SAVES_SYSTEM)
1645 /* can use the macros */
1646 #define stg_getc(stream) getc((FILE *) (stream))
1647 #define stg_putc(c,stream) putc((c),((FILE *) (stream)))
1649 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1650 #define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1651 #define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1654 int initialize_virtual_timer(int us);
1655 int install_segv_handler(STG_NO_ARGS);
1656 int install_vtalrm_handler(STG_NO_ARGS);
1657 void initUserSignals(STG_NO_ARGS);
1658 void blockUserSignals(STG_NO_ARGS);
1659 void unblockUserSignals(STG_NO_ARGS);
1660 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1661 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1662 IF_RTS(void AwaitEvent(I_ delta);)
1664 #if defined(_POSIX_SOURCE) && !defined(nextstep3_TARGET_OS)
1665 /* For nextstep3_TARGET_OS comment see stgdefs.h. CaS */
1666 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1667 #define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1668 #define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1669 #define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1671 extern I_ sig_install PROTO((I_, I_));
1672 #define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1673 #define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1674 #define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1677 #define STG_SIG_DFL (-1)
1678 #define STG_SIG_IGN (-2)
1679 #define STG_SIG_ERR (-3)
1681 StgInt getErrorHandler(STG_NO_ARGS);
1683 void raiseError PROTO((StgStablePtr handler));
1684 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1686 void decrementErrorCount(STG_NO_ARGS);
1688 #define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1689 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1692 %************************************************************************
1694 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1696 %************************************************************************
1699 The type of these should be:
1702 makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1703 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1706 Since world-tokens are no longer explicitly passed around, the
1707 implementations have a few less arguments/results.
1709 The simpler one is @deRefStablePointer#@ (which is only a primop
1710 because it is more polymorphic than is allowed of a ccall).
1715 #define deRefStablePtrZh(ri,sp) \
1718 fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1719 EXIT(EXIT_FAILURE); \
1724 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1726 #define deRefStablePtrZh(ri,sp) \
1727 ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1730 Declarations for other stable pointer operations.
1733 void freeStablePointer PROTO((I_ stablePtr));
1735 void enterStablePtr PROTO((StgStablePtr, StgFunPtr));
1736 void performIO PROTO((StgStablePtr));
1737 I_ enterInt PROTO((StgStablePtr));
1738 I_ enterFloat PROTO((StgStablePtr));
1739 P_ deRefStablePointer PROTO((StgStablePtr));
1740 IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
1741 IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
1742 IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
1743 IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
1745 EXTFUN(stopPerformIODirectReturn);
1746 EXTFUN(startPerformIO);
1747 EXTFUN(stopEnterIntDirectReturn);
1748 EXTFUN(startEnterInt);
1749 EXTFUN(stopEnterFloatDirectReturn);
1750 EXTFUN(startEnterFloat);
1752 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1756 IF_RTS(extern I_ ErrorIO_call_count;)
1759 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1760 if we're unlucky, it will have to allocate a new table and copy the
1761 old bit over. Since we might, very occasionally, have to call the
1762 garbage collector, this has to be a macro... sigh!
1764 NB @newSP@ is required because it is entirely possible that
1765 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1766 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1768 Another obscure piece of coding is the recalculation of the size of
1769 the table. We do this just in case Jim's threads decide they want to
1770 context switch---in which case any stack-allocated variables may get
1771 trashed. (If only there was a special heap check which didn't
1772 consider context switching...)
1777 /* Calculate SP Table size from number of pointers */
1778 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1780 /* Calculate number of pointers in new table from number in old table:
1781 any strictly increasing expression will do here */
1782 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1784 void enlargeSPTable PROTO((P_, P_));
1786 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1788 EXTDATA_RO(StablePointerTable_info); \
1789 EXTDATA(UnusedSP); \
1790 StgStablePtr newSP; \
1792 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1793 { /* Variables used before the heap check */ \
1794 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1795 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1796 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1797 HEAP_CHK(liveness, _FHS+NewSize, 0); \
1799 { /* Variables used after the heap check - same values */ \
1800 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1801 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1802 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1803 P_ SPTable = Hp + 1 - (_FHS + NewSize); \
1805 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
1806 SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1807 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
1808 StorageMgrInfo.StablePointerTable = SPTable; \
1812 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
1813 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1814 CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
1815 stablePtr = newSP; \
1820 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1823 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1824 EXIT(EXIT_FAILURE); \
1830 %************************************************************************
1832 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1834 %************************************************************************
1836 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1837 can expect three parameters: the two arguments and a "register" to put
1840 Message to Will: This primop breaks referential transparency so badly
1841 you might want to leave it out. On the other hand, if you hide it
1842 away in an appropriate monad, it's perfectly safe. [ADR]
1844 Note that this primop is non-deterministic: different results can be
1845 obtained depending on just what the garbage collector (and code
1846 optimiser??) has done. However, we can guarantee that if two objects
1847 are pointer-equal, they have the same denotation --- the converse most
1848 certainly doesn't hold.
1850 ToDo ADR: The degree of non-determinism could be greatly reduced by
1851 following indirections.
1854 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1857 %************************************************************************
1859 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1861 %************************************************************************
1863 Assuming local sparking in some form, we can now inline the spark request.
1865 We build a doubly-linked list in the heap, so that we can handle FIFO
1866 or LIFO scheduling as we please.
1868 Anything with tag >= 0 is in WHNF, so we discard it.
1873 ED_(PrelBase_Z91Z93_closure);
1877 #define parZh(r,node) \
1878 PARZh(r,node,1,0,0,0,0,0)
1880 #define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1881 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
1883 #define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1884 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
1886 #define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1887 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
1889 #define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1890 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
1892 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
1895 if (SHOULD_SPARK(node)) { \
1898 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local); \
1899 if (local==2) { /* special case for parAtAbs */ \
1900 GranSimSparkAtAbs(result,(I_)where,identifier);\
1901 } else if (local==3) { /* special case for parAtRel */ \
1902 GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier); \
1904 GranSimSparkAt(result,where,identifier); \
1906 context_switch = 1; \
1908 RestoreAllStgRegs(); \
1909 } else if (do_qp_prof) { \
1910 I_ tid = threadId++; \
1911 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1913 r = 1; /* return code for successful spark -- HWL */ \
1916 #define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1917 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
1919 #define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1920 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
1924 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1926 if (SHOULD_SPARK(node)) { \
1929 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1930 add_to_spark_queue(result); \
1931 GranSimSpark(local,(P_)node); \
1932 context_switch = 1; \
1934 RestoreAllStgRegs(); \
1935 } else if (do_qp_prof) { \
1936 I_ tid = threadId++; \
1937 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1939 r = 1; /* return code for successful spark -- HWL */ \
1944 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1947 if (SHOULD_SPARK(node)) { \
1948 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1949 ADD_TO_SPARK_QUEUE(result); \
1950 SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \
1951 /* context_switch = 1; not needed any more -- HWL */ \
1952 } else if (do_qp_prof) { \
1953 I_ tid = threadId++; \
1954 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1956 r = 1; /* return code for successful spark -- HWL */ \
1961 #define copyableZh(r,node) \
1962 /* copyable not yet implemented!! */
1964 #define noFollowZh(r,node) \
1965 /* noFollow not yet implemented!! */
1969 extern I_ required_thread_count;
1972 #define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++
1978 Note that we must bump the required thread count NOW, rather
1979 than when the thread is actually created.
1982 #define forkZh(r,liveness,node) \
1984 while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
1985 DO_YIELD((liveness << 1) | 1); \
1987 if (SHOULD_SPARK(node)) { \
1988 *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
1989 } else if (DO_QP_PROF) { \
1990 I_ tid = threadId++; \
1991 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1993 required_thread_count++; \
1994 context_switch = 1; \
1995 r = 1; /* Should not be necessary */ \
1998 #define parZh(r,node) \
2001 if (SHOULD_SPARK(node) && \
2002 PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
2003 *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
2007 I_ tid = threadId++; \
2008 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
2011 r = 1; /* Should not be necessary */ \
2017 The following seq# code should only be used in unoptimized code.
2018 Be warned: it's a potential bug-farm.
2020 First we push two words on the B stack: the current value of RetReg
2021 (which may or may not be live), and a continuation snatched largely out
2022 of thin air (it's a point within this code block). Then we set RetReg
2023 to the special polymorphic return code for seq, load up Node with the
2024 closure to be evaluated, and we're off. When the eval returns to the
2025 polymorphic seq return point, the two words are popped off the B stack,
2026 RetReg is restored, and we jump to the continuation, completing the
2027 primop and going on our merry way.
2033 #define seqZh(r,liveness,node) \
2036 /* STK_CHK(liveness,0,2,0,0,0,0); */ \
2037 /* SpB -= BREL(2); */ \
2038 SpB[BREL(0)] = (W_) RetReg; \
2039 SpB[BREL(1)] = (W_) &&cont; \
2040 RetReg = (StgRetAddr) vtbl_seq; \
2043 InfoPtr = (D_)(INFO_PTR(Node)); \
2044 JMP_(ENTRY_CODE(InfoPtr)); \
2046 r = 1; /* Should be unnecessary */ \
2049 #endif /* CONCURRENT */
2052 %************************************************************************
2054 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2056 %************************************************************************
2058 [Based on previous MallocPtr comments -- SOF]
2060 This macro is used to construct a ForeignObj on the heap.
2062 What this does is plug the pointer (which will be in a local
2063 variable) together with its finalising/free routine, into a fresh heap
2064 object and then sets a result (which will be a register) to point
2065 to the fresh heap object.
2067 To accommodate per-object finalisation, augment the macro with a
2068 finalisation routine argument. Nothing spectacular, just plug the
2069 pointer to the routine into the ForeignObj -- SOF 4/96
2071 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2072 too? (It's if you want to use the SPAT profiling tools to
2073 characterize program behavior by ``activity'' -- tail-calling,
2074 heap-checking, etc. -- see Ticky.lh. It is quite specialized.
2077 (Swapped first two arguments to make it come into line with what appears
2078 to be `standard' format, return register then liveness mask. -- SOF 4/96)
2083 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2085 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2089 HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0); \
2090 CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */ \
2092 result = Hp + 1 - (_FHS + ForeignObj_SIZE); \
2093 SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
2094 ForeignObj_CLOSURE_DATA(result) = (P_)mptr; \
2095 ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise; \
2096 ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
2097 StorageMgrInfo.ForeignObjList = result; \
2100 /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
2102 result[0],result[1], \
2103 result[2],result[3]);*/ \
2105 CHECK_ForeignObj_CLOSURE( result ); \
2106 VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2108 (r) = (P_) result; \
2111 #define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
2114 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2117 fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2118 EXIT(EXIT_FAILURE); \
2121 #define writeForeignObjZh(res,datum) \
2124 fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
2125 EXIT(EXIT_FAILURE); \
2132 End-of-file's multi-slurp protection:
2134 #endif /* ! STGMACROS_H */