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 #define gtIntZh(r,a,b) r=(I_)((a) >(b))
394 #define geIntZh(r,a,b) r=(I_)((a)>=(b))
395 #define eqIntZh(r,a,b) r=(I_)((a)==(b))
396 #define neIntZh(r,a,b) r=(I_)((a)!=(b))
397 #define ltIntZh(r,a,b) r=(I_)((a) <(b))
398 #define leIntZh(r,a,b) r=(I_)((a)<=(b))
400 #define gtWordZh(r,a,b) r=(I_)((a) >(b))
401 #define geWordZh(r,a,b) r=(I_)((a)>=(b))
402 #define eqWordZh(r,a,b) r=(I_)((a)==(b))
403 #define neWordZh(r,a,b) r=(I_)((a)!=(b))
404 #define ltWordZh(r,a,b) r=(I_)((a) <(b))
405 #define leWordZh(r,a,b) r=(I_)((a)<=(b))
407 #define gtAddrZh(r,a,b) r=(I_)((a) >(b))
408 #define geAddrZh(r,a,b) r=(I_)((a)>=(b))
409 #define eqAddrZh(r,a,b) r=(I_)((a)==(b))
410 #define neAddrZh(r,a,b) r=(I_)((a)!=(b))
411 #define ltAddrZh(r,a,b) r=(I_)((a) <(b))
412 #define leAddrZh(r,a,b) r=(I_)((a)<=(b))
414 #define gtFloatZh(r,a,b) r=(I_)((a)> (b))
415 #define geFloatZh(r,a,b) r=(I_)((a)>=(b))
416 #define eqFloatZh(r,a,b) r=(I_)((a)==(b))
417 #define neFloatZh(r,a,b) r=(I_)((a)!=(b))
418 #define ltFloatZh(r,a,b) r=(I_)((a)< (b))
419 #define leFloatZh(r,a,b) r=(I_)((a)<=(b))
421 #define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
422 #define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
423 #define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
424 #define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
425 #define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
426 #define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
429 %************************************************************************
431 \subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
433 %************************************************************************
435 We cast the chars in case one of them is a literal (so C things work right
436 even for 8-bit chars).
438 #define ordZh(r,a) r=(I_)((W_) (a))
439 #define chrZh(r,a) r=(StgChar)((W_)(a))
442 %************************************************************************
444 \subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
446 %************************************************************************
449 I_ stg_div PROTO((I_ a, I_ b));
451 #define plusIntZh(r,a,b) r=(a)+(b)
452 #define minusIntZh(r,a,b) r=(a)-(b)
453 #define timesIntZh(r,a,b) r=(a)*(b)
454 #define quotIntZh(r,a,b) r=(a)/(b)
455 #define divIntZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
456 #define remIntZh(r,a,b) r=(a)%(b)
457 #define negateIntZh(r,a) r=-(a)
460 %************************************************************************
462 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
464 %************************************************************************
467 #define andZh(r,a,b) r=(a)&(b)
468 #define orZh(r,a,b) r=(a)|(b)
469 #define notZh(r,a) r=~(a)
471 #define shiftLZh(r,a,b) r=(a)<<(b)
472 #define shiftRAZh(r,a,b) r=(a)>>(b)
473 #define shiftRLZh(r,a,b) r=(a)>>(b)
474 #define iShiftLZh(r,a,b) r=(a)<<(b)
475 #define iShiftRAZh(r,a,b) r=(a)>>(b)
476 #define iShiftRLZh(r,a,b) r=(a)>>(b)
478 #define int2WordZh(r,a) r=(W_)(a)
479 #define word2IntZh(r,a) r=(I_)(a)
482 %************************************************************************
484 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
486 %************************************************************************
489 #define int2AddrZh(r,a) r=(A_)(a)
490 #define addr2IntZh(r,a) r=(I_)(a)
493 %************************************************************************
495 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
497 %************************************************************************
500 #define plusFloatZh(r,a,b) r=(a)+(b)
501 #define minusFloatZh(r,a,b) r=(a)-(b)
502 #define timesFloatZh(r,a,b) r=(a)*(b)
503 #define divideFloatZh(r,a,b) r=(a)/(b)
504 #define negateFloatZh(r,a) r=-(a)
506 #define int2FloatZh(r,a) r=(StgFloat)(a)
507 #define float2IntZh(r,a) r=(I_)(a)
509 #define expFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
510 #define logFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
511 #define sqrtFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
512 #define sinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
513 #define cosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
514 #define tanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
515 #define asinFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
516 #define acosFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
517 #define atanFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
518 #define sinhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
519 #define coshFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
520 #define tanhFloatZh(r,a) r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
521 #define powerFloatZh(r,a,b) r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
523 /* encoding/decoding given w/ Integer stuff */
526 %************************************************************************
528 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
530 %************************************************************************
533 #define plusDoubleZh(r,a,b) r=(a)+(b)
534 #define minusDoubleZh(r,a,b) r=(a)-(b)
535 #define timesDoubleZh(r,a,b) r=(a)*(b)
536 #define divideDoubleZh(r,a,b) r=(a)/(b)
537 #define negateDoubleZh(r,a) r=-(a)
539 #define int2DoubleZh(r,a) r=(StgDouble)(a)
540 #define double2IntZh(r,a) r=(I_)(a)
542 #define float2DoubleZh(r,a) r=(StgDouble)(a)
543 #define double2FloatZh(r,a) r=(StgFloat)(a)
545 #define expDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
546 #define logDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
547 #define sqrtDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
548 #define sinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
549 #define cosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
550 #define tanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
551 #define asinDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
552 #define acosDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
553 #define atanDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
554 #define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
555 #define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
556 #define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
557 #define powerDoubleZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
560 %************************************************************************
562 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
564 %************************************************************************
566 Dirty macros we use for the real business.
568 INVARIANT: When one of these macros is called, the only live data is
569 tidily on the STG stacks or in the STG registers (the code generator
570 ensures this). If there are any pointer-arguments, they will be in
571 the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
573 OK, here are the real macros:
575 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da) \
578 I_ space = size_chk_macro(sa); \
580 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
581 GMP_HEAP_LOOKAHEAD(liveness,space); \
583 /* Now we can initialise (post possible GC) */ \
586 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
588 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
590 /* Perform the operation */ \
591 SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg); \
593 GMP_HEAP_HANDBACK(); /* restore Hp */ \
594 (ar) = result.alloc; \
595 (sr) = result.size; \
596 (dr) = (B_) (result.d - DATA_HS); \
597 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
601 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
605 I_ space = size_chk_macro(s1,s2); \
607 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
608 GMP_HEAP_LOOKAHEAD(liveness,space); \
610 /* Now we can initialise (post possible GC) */ \
613 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
616 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
618 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result); \
620 /* Perform the operation */ \
621 SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
623 GMP_HEAP_HANDBACK(); /* restore Hp */ \
624 (ar) = result.alloc; \
625 (sr) = result.size; \
626 (dr) = (B_) (result.d - DATA_HS); \
627 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
630 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
635 I_ space = size_chk_macro(s1,s2); \
637 /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
638 GMP_HEAP_LOOKAHEAD(liveness,space); \
640 /* Now we can initialise (post possible GC) */ \
643 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
646 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
648 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1); \
649 SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2); \
651 /* Perform the operation */ \
652 SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
654 GMP_HEAP_HANDBACK(); /* restore Hp */ \
655 (ar1) = result1.alloc; \
656 (sr1) = result1.size; \
657 (dr1) = (B_) (result1.d - DATA_HS); \
658 (ar2) = result2.alloc; \
659 (sr2) = result2.size; \
660 (dr2) = (B_) (result2.d - DATA_HS); \
664 Some handy size-munging macros: sometimes gratuitously {\em conservative}.
665 The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
666 The \tr{__abs} stuff is because negative-ness of GMP things is encoded
669 #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a)))
670 #define GMP_SIZE_ONE() (2 + DATA_HS + 16)
671 #define GMP_SAME_SIZE(a) (__abs(a) + DATA_HS + 16)
672 #define GMP_MAX_SIZE(a,b) ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
673 /* NB: the +1 is for the carry (or whatever) */
674 #define GMP_2MAX_SIZE(a,b) (2 * GMP_MAX_SIZE(a,b))
675 #define GMP_ADD_SIZES(a,b) (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
676 /* the +1 may just be paranoia */
679 For the Integer/GMP stuff, we have macros that {\em look ahead} for
680 some space, but don't actually grab it.
682 If there are live pointers at the time of the lookahead, the caller
683 must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
684 handled normally. We achieve this by having the code generator {\em
685 always} pass args to may-invoke-GC primitives in registers, using the
686 normal pointers-first policy. This means that, if we do go to garbage
687 collection, everything is already in the Right Place.
689 Saving and restoring Hp register so the MP allocator can see them. If we are
690 performing liftime profiling need to save and restore HpLim as well so that
691 it can be bumped if allocation occurs.
693 The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
694 it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
698 #define GMP_HEAP_LOOKAHEAD(liveness,n) \
700 HEAP_CHK_AND_RESTORE_N(liveness,n,0); \
702 UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
703 SAVE_Hp = Hp; /* Hand over the hp */ \
704 DEBUG_SetGMPAllocBudget(n) \
707 #define GMP_HEAP_HANDBACK() \
709 DEBUG_ResetGMPAllocBudget()
713 void *stgAllocForGMP PROTO((size_t size_in_bytes));
714 void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
715 void stgDeallocForGMP PROTO((void *ptr, size_t size));
718 extern StgInt DEBUG_GMPAllocBudget;
719 #define DEBUG_SetGMPAllocBudget(n) DEBUG_GMPAllocBudget = (n);
720 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
722 #define DEBUG_SetGMPAllocBudget(n) /*nothing*/
723 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
727 The real business (defining Integer primops):
729 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
730 gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
732 #define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
733 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
734 #define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
735 gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
736 #define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
737 gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
739 /* div, mod, quot, rem are defined w/ quotRem & divMod */
741 #define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
742 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
743 #define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
744 gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
747 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
748 fellow (returns -ve, 0, or +ve).
750 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */ \
753 /* Does not allocate memory */ \
757 arg1.d = (unsigned long int *) (BYTE_ARR_CTS(d1)); \
760 arg2.d = (unsigned long int *) (BYTE_ARR_CTS(d2)); \
762 (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2); \
769 #define integer2IntZh(r, hp, aa,sa,da) \
771 /* Does not allocate memory */ \
775 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
777 (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg); \
780 /* Since we're forced to know a little bit about MP_INT layout to do this with
781 pre-allocated heap, we just inline the whole of mpz_init_set_si here.
782 ** DIRE WARNING. if mpz_init_set_si changes, so does this! ***
785 #define int2IntegerZh(ar,sr,dr, hp, i) \
786 { StgInt val; /* to snaffle arg to avoid aliasing */ \
788 val = (i); /* snaffle... */ \
790 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
792 if ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); } \
793 else if ((val) > 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
794 else /* val==0 */ { (sr) = 0; } \
796 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
799 #define word2IntegerZh(ar,sr,dr, hp, i) \
800 { StgWord val; /* to snaffle arg to avoid aliasing */ \
802 val = (i); /* snaffle... */ \
804 SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
806 if ((val) != 0) { (sr) = 1; (hp)[DATA_HS] = (val); } \
807 else /* val==0 */ { (sr) = 0; } \
809 (dr) = (B_)(hp); /* dr is an StgByteArray */ \
814 Then there are a few oddments to make life easier:
818 The "str" argument must be a literal C string.
820 addr2Integer( ..., "foo") OK!
823 addr2Integer( ..., x) NO! NO!
826 #define addr2IntegerZh(ar,sr,dr, liveness, str) \
828 /* taking the number of bytes/8 as the number of words of lookahead \
829 is plenty conservative */ \
830 I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1); \
832 GMP_HEAP_LOOKAHEAD(liveness, space); \
834 /* Perform the operation */ \
835 if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
838 GMP_HEAP_HANDBACK(); /* restore Hp */ \
839 (ar) = result.alloc; \
840 (sr) = result.size; \
841 (dr) = (B_) (result.d - DATA_HS); \
842 /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
846 Encoding and decoding float-ish things is pretty Integer-ish. We use
847 these pretty magical support functions, essentially stolen from Lennart:
849 StgFloat __encodeFloat PROTO((MP_INT *, I_));
850 void __decodeFloat PROTO((MP_INT * /*result1*/,
854 StgDouble __encodeDouble PROTO((MP_INT *, I_));
855 void __decodeDouble PROTO((MP_INT * /*result1*/,
860 Some floating-point format info, made with the \tr{enquire} program
861 (version~4.3) [comes with gcc].
863 /* this should be done by CPU architecture, insofar as possible [WDP] */
865 #if sparc_TARGET_ARCH \
866 || alpha_TARGET_ARCH \
867 || hppa1_1_TARGET_ARCH \
868 || i386_TARGET_ARCH \
869 || m68k_TARGET_ARCH \
870 || mipsel_TARGET_ARCH \
871 || mipseb_TARGET_ARCH \
872 || powerpc_TARGET_ARCH
874 /* yes, it is IEEE floating point */
875 #include "ieee-flpt.h"
877 #if alpha_dec_osf1_TARGET \
878 || i386_TARGET_ARCH \
879 || mipsel_TARGET_ARCH
881 #undef BIGENDIAN /* little-endian weirdos... */
886 #else /* unknown floating-point format */
888 ******* ERROR *********** Any ideas about floating-point format?
890 #endif /* unknown floating-point */
894 #if alpha_dec_osf1_TARGET
895 #define encodeFloatZh(r, hp, aa,sa,da, expon) encodeDoubleZh(r, hp, aa,sa,da, expon)
897 #define encodeFloatZh(r, hp, aa,sa,da, expon) \
899 /* Does not allocate memory */ \
903 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
905 r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon)); \
909 #define encodeDoubleZh(r, hp, aa,sa,da, expon) \
911 /* Does not allocate memory */ \
915 arg.d = (unsigned long int *) (BYTE_ARR_CTS(da)); \
917 r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
920 #if alpha_dec_osf1_TARGET
921 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) decodeDoubleZh(exponr, ar,sr,dr, hp, f)
923 #define decodeFloatZh(exponr, ar,sr,dr, hp, f) \
926 StgFloat arg = (f); \
928 /* Be prepared to tell Lennart-coded __decodeFloat */ \
929 /* where mantissa.d can be put (it does not care about the rest) */ \
930 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
931 mantissa.d = (hp) + DATA_HS; \
933 /* Perform the operation */ \
934 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg); \
936 ar = mantissa.alloc; \
937 sr = mantissa.size; \
942 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f) \
945 StgDouble arg = (f); \
947 /* Be prepared to tell Lennart-coded __decodeDouble */ \
948 /* where mantissa.d can be put (it does not care about the rest) */ \
949 SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0); \
950 mantissa.d = (hp) + DATA_HS; \
952 /* Perform the operation */ \
953 SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg); \
955 ar = mantissa.alloc; \
956 sr = mantissa.size; \
961 %************************************************************************
963 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
965 %************************************************************************
967 With GCC, we use magic non-standard inlining; for other compilers, we
968 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
970 (The @OMIT_...@ is only used in compiling some of the RTS, none of
971 which uses these anyway.)
974 #if alpha_TARGET_ARCH \
975 || i386_TARGET_ARCH \
978 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
979 #define PK_FLT(src) (*(StgFloat *)(src))
981 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
982 #define PK_DBL(src) (*(StgDouble *)(src))
984 #else /* not m68k || alpha || i[34]86 */
986 /* Special handling for machines with troublesome alignment constraints */
988 #define FLOAT_ALIGNMENT_TROUBLES TRUE
990 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
992 void ASSIGN_DBL PROTO((W_ [], StgDouble));
993 StgDouble PK_DBL PROTO((W_ []));
994 void ASSIGN_FLT PROTO((W_ [], StgFloat));
995 StgFloat PK_FLT PROTO((W_ []));
997 #else /* yes, its __GNUC__ && we really want them */
999 #if sparc_TARGET_ARCH
1001 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1002 #define PK_FLT(src) (*(StgFloat *)(src))
1004 #define ASSIGN_DBL(dst,src) \
1005 __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1006 "=m" (((P_)(dst))[1]) : "f" (src));
1008 #define PK_DBL(src) \
1009 ( { register double d; \
1010 __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1011 "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1016 /* (not very) forward prototype declarations */
1017 void ASSIGN_DBL PROTO((W_ [], StgDouble));
1018 StgDouble PK_DBL PROTO((W_ []));
1019 void ASSIGN_FLT PROTO((W_ [], StgFloat));
1020 StgFloat PK_FLT PROTO((W_ []));
1024 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1028 p_dest[0] = y.du.dhi;
1029 p_dest[1] = y.du.dlo;
1032 /* GCC also works with this version, but it generates
1033 the same code as the previous one, and is not ANSI
1035 #define ASSIGN_DBL( p_dest, src ) \
1036 *p_dest = ((double_thing) src).du.dhi; \
1037 *(p_dest+1) = ((double_thing) src).du.dlo \
1045 y.du.dhi = p_src[0];
1046 y.du.dlo = p_src[1];
1052 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1068 #endif /* ! sparc */
1070 #endif /* __GNUC__ */
1072 #endif /* not __m68k__ */
1075 %************************************************************************
1077 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1079 %************************************************************************
1081 We regularly use this macro to fish the ``contents'' part
1082 out of a DATA or TUPLE closure, which is what is used for
1083 non-ptr and ptr arrays (respectively).
1085 BYTE_ARR_CTS returns a @C_ *@!
1087 We {\em ASSUME} we can use the same macro for both!!
1091 #define BYTE_ARR_CTS(a) \
1092 ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info); \
1093 ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1094 #define PTRS_ARR_CTS(a) \
1095 ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info) \
1096 || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1097 ((a)+MUTUPLE_HS);} )
1099 #define BYTE_ARR_CTS(a) ((char *) (((StgPtr) (a))+DATA_HS))
1100 #define PTRS_ARR_CTS(a) ((a)+MUTUPLE_HS)
1104 extern I_ genSymZh(STG_NO_ARGS);
1105 extern I_ resetGenSymZh(STG_NO_ARGS);
1106 extern I_ incSeqWorldZh(STG_NO_ARGS);
1108 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1111 OK, the easy ops first: (all except \tr{newArr*}:
1113 (OLD:) VERY IMPORTANT! The read/write/index primitive ops
1114 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1115 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1116 This is because you might be trying to take apart a C struct, where
1117 the offset from the start of the struct isn't a multiple of the
1118 size of the thing you're getting. Hence the @(char *)@ casts.
1120 EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
1121 are in Blahs. WDP 95/08
1123 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1124 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1126 In the case of @Array#@ (which contain pointers), the offset is in units
1127 of one ptr (not bytes).
1130 #define sameMutableArrayZh(r,a,b) r=(I_)((a)==(b))
1131 #define sameMutableByteArrayZh(r,a,b) r=(I_)((B_)(a)==(B_)(b))
1133 #define readArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1135 #define readCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1136 #define readIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1137 #define readAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1138 #define readFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1139 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1141 /* result ("r") arg ignored in write macros! */
1142 #define writeArrayZh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1144 #define writeCharArrayZh(a,i,v) ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1145 #define writeIntArrayZh(a,i,v) ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1146 #define writeAddrArrayZh(a,i,v) ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1147 #define writeFloatArrayZh(a,i,v) \
1148 ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1149 #define writeDoubleArrayZh(a,i,v) \
1150 ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1152 #define indexArrayZh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)]
1154 #define indexCharArrayZh(r,a,i) indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1155 #define indexIntArrayZh(r,a,i) indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1156 #define indexAddrArrayZh(r,a,i) indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1157 #define indexFloatArrayZh(r,a,i) indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1158 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1160 #define indexCharOffAddrZh(r,a,i) r= ((C_ *)(a))[i]
1161 #define indexIntOffAddrZh(r,a,i) r= ((I_ *)(a))[i]
1162 #define indexAddrOffAddrZh(r,a,i) r= ((PP_)(a))[i]
1163 #define indexFloatOffAddrZh(r,a,i) r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1164 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1166 /* Freezing arrays-of-ptrs requires changing an info table, for the
1167 benefit of the generational collector. It needs to scavenge mutable
1168 objects, even if they are in old space. When they become immutable,
1169 they can be removed from this scavenge list. */
1170 #define unsafeFreezeArrayZh(r,a) \
1174 FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info); \
1178 #define unsafeFreezeByteArrayZh(r,a) r=(B_)(a)
1181 Now the \tr{newArr*} ops:
1185 --------------------
1186 Will: ToDo: we need to find suitable places to put this comment, and the
1187 "in-general" one which follows.
1189 ************ Nota Bene. The "n" in this macro is guaranteed to
1190 be a register, *not* (say) Node[1]. That means that it is guaranteed
1191 to survive GC, provided only that the register is kept unaltered.
1192 This is important, because "n" is used after the HEAP_CHK.
1194 In general, *all* parameters to these primitive-op macros are always
1195 registers. (Will: For exactly *which* primitive-op macros is this guaranteed?
1196 Exactly those which can trigger GC?)
1197 ------------------------
1199 NOTE: the above may now be OLD (WDP 94/02/10)
1203 For char arrays, the size is in {\em BYTES}.
1206 #define newCharArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(C_))
1207 #define newIntArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(I_))
1208 #define newAddrArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(P_))
1209 #define newFloatArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgFloat))
1210 #define newDoubleArrayZh(r,liveness,n) newByteArray(r,liveness,(n) * sizeof(StgDouble))
1212 #define newByteArray(r,liveness,n) \
1217 HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0); \
1218 size = BYTES_TO_STGWORDS(n); \
1219 ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */; \
1220 CC_ALLOC(CCC,DATA_HS+size,ARR_K); \
1222 result = Hp-(DATA_HS+size)+1; \
1223 SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0); \
1228 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1229 The initialisation value is guaranteed to be in a register,
1230 and will be indicated by the liveness mask, so it's ok to do
1231 a \tr{HEAP_CHK}, which may trigger GC.
1234 /* The new array initialization routine for the NCG */
1235 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1237 #define newArrayZh(r,liveness,n,init) \
1242 HEAP_CHK(liveness, MUTUPLE_HS+(n),0); \
1243 ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1244 CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */ \
1246 result = Hp + 1 - (MUTUPLE_HS+(n)); \
1247 SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1248 for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1256 %************************************************************************
1258 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1260 %************************************************************************
1263 ED_(Prelude_Z91Z93_closure);
1265 #define newSynchVarZh(r, hp) \
1267 ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1268 CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */ \
1269 SET_SVAR_HDR(hp,EmptySVar_info,CCC); \
1270 SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Prelude_Z91Z93_closure; \
1278 void Yield PROTO((W_));
1280 #define takeMVarZh(r, liveness, node) \
1282 while (INFO_PTR(node) != (W_) FullSVar_info) { \
1283 if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \
1284 SVAR_HEAD(node) = CurrentTSO; \
1286 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1287 TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \
1288 SVAR_TAIL(node) = CurrentTSO; \
1289 DO_YIELD(liveness << 1); \
1291 SET_INFO_PTR(node, EmptySVar_info); \
1292 r = SVAR_VALUE(node); \
1293 SVAR_VALUE(node) = Prelude_Z91Z93_closure; \
1298 #define takeMVarZh(r, liveness, node) \
1300 if (INFO_PTR(node) != (W_) FullSVar_info) { \
1301 /* Don't wrap the calls; we're done with STG land */\
1303 fprintf(stderr, "takeMVar#: MVar is empty.\n"); \
1304 EXIT(EXIT_FAILURE); \
1306 SET_INFO_PTR(node, EmptySVar_info); \
1307 r = SVAR_VALUE(node); \
1308 SVAR_VALUE(node) = Prelude_Z91Z93_closure; \
1319 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1320 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1321 /* the CurrentProc. This means we have an implicit context switch after */
1322 /* putMVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1324 #define putMVarZh(node, value) \
1327 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1328 /* Don't wrap the calls; we're done with STG land */\
1330 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1331 EXIT(EXIT_FAILURE); \
1333 SET_INFO_PTR(node, FullSVar_info); \
1334 SVAR_VALUE(node) = value; \
1335 tso = SVAR_HEAD(node); \
1336 if (tso != (P_) Prelude_Z91Z93_closure) { \
1338 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1339 if (ThreadQueueHd == Prelude_Z91Z93_closure) \
1340 ThreadQueueHd = tso; \
1342 TSO_LINK(ThreadQueueTl) = tso; \
1343 ThreadQueueTl = tso; \
1344 SVAR_HEAD(node) = TSO_LINK(tso); \
1345 TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \
1346 if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \
1347 SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \
1353 #define putMVarZh(node, value) \
1356 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1357 /* Don't wrap the calls; we're done with STG land */\
1359 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1360 EXIT(EXIT_FAILURE); \
1362 SET_INFO_PTR(node, FullSVar_info); \
1363 SVAR_VALUE(node) = value; \
1364 tso = SVAR_HEAD(node); \
1365 if (tso != (P_) Prelude_Z91Z93_closure) { \
1367 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1368 if (RunnableThreadsHd == Prelude_Z91Z93_closure) \
1369 RunnableThreadsHd = tso; \
1371 TSO_LINK(RunnableThreadsTl) = tso; \
1372 RunnableThreadsTl = tso; \
1373 SVAR_HEAD(node) = TSO_LINK(tso); \
1374 TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure; \
1375 if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure) \
1376 SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure; \
1384 #define putMVarZh(node, value) \
1387 if (INFO_PTR(node) == (W_) FullSVar_info) { \
1388 /* Don't wrap the calls; we're done with STG land */\
1390 fprintf(stderr, "putMVar#: MVar already full.\n"); \
1391 EXIT(EXIT_FAILURE); \
1393 SET_INFO_PTR(node, FullSVar_info); \
1394 SVAR_VALUE(node) = value; \
1403 #define readIVarZh(r, liveness, node) \
1405 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1406 if (SVAR_HEAD(node) == Prelude_Z91Z93_closure) \
1407 SVAR_HEAD(node) = CurrentTSO; \
1409 TSO_LINK(SVAR_TAIL(node)) = CurrentTSO; \
1410 TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure; \
1411 SVAR_TAIL(node) = CurrentTSO; \
1412 DO_YIELD(liveness << 1); \
1414 r = SVAR_VALUE(node); \
1419 #define readIVarZh(r, liveness, node) \
1421 if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) { \
1422 /* Don't wrap the calls; we're done with STG land */\
1424 fprintf(stderr, "readIVar#: IVar is empty.\n"); \
1425 EXIT(EXIT_FAILURE); \
1427 r = SVAR_VALUE(node); \
1438 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1439 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1440 /* the CurrentProc. This means we have an implicit context switch after */
1441 /* writeIVar even if unfair scheduling is used in GranSim (default)! -- HWL */
1443 #define writeIVarZh(node, value) \
1446 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1447 /* Don't wrap the calls; we're done with STG land */\
1449 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1450 EXIT(EXIT_FAILURE); \
1452 tso = SVAR_HEAD(node); \
1453 if (tso != (P_) Prelude_Z91Z93_closure) { \
1454 if (ThreadQueueHd == Prelude_Z91Z93_closure) \
1455 ThreadQueueHd = tso; \
1457 TSO_LINK(ThreadQueueTl) = tso; \
1458 while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \
1460 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1461 tso = TSO_LINK(tso); \
1464 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1465 ThreadQueueTl = tso; \
1467 /* Don't use freeze, since it's conditional on GC */ \
1468 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1469 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1470 SVAR_VALUE(node) = value; \
1475 #define writeIVarZh(node, value) \
1478 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1479 /* Don't wrap the calls; we're done with STG land */\
1481 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1482 EXIT(EXIT_FAILURE); \
1484 tso = SVAR_HEAD(node); \
1485 if (tso != (P_) Prelude_Z91Z93_closure) { \
1486 if (RunnableThreadsHd == Prelude_Z91Z93_closure) \
1487 RunnableThreadsHd = tso; \
1489 TSO_LINK(RunnableThreadsTl) = tso; \
1490 while(TSO_LINK(tso) != Prelude_Z91Z93_closure) { \
1492 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1493 tso = TSO_LINK(tso); \
1496 STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO); \
1497 RunnableThreadsTl = tso; \
1499 /* Don't use freeze, since it's conditional on GC */ \
1500 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1501 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1502 SVAR_VALUE(node) = value; \
1509 #define writeIVarZh(node, value) \
1512 if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) { \
1513 /* Don't wrap the calls; we're done with STG land */\
1515 fprintf(stderr, "writeIVar#: IVar already full.\n");\
1516 EXIT(EXIT_FAILURE); \
1518 /* Don't use freeze, since it's conditional on GC */ \
1519 SET_INFO_PTR(node, ImMutArrayOfPtrs_info); \
1520 MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1); \
1521 SVAR_VALUE(node) = value; \
1527 %************************************************************************
1529 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1531 %************************************************************************
1536 /* ToDo: for GRAN */
1538 #define delayZh(liveness, us) \
1540 if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
1541 WaitingThreadsHd = CurrentTSO; \
1543 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1544 WaitingThreadsTl = CurrentTSO; \
1545 TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
1546 TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1547 DO_YIELD(liveness << 1); \
1552 #define delayZh(liveness, us) \
1555 fprintf(stderr, "delay#: unthreaded build.\n"); \
1556 EXIT(EXIT_FAILURE); \
1563 /* ToDo: something for GRAN */
1565 #define waitReadZh(liveness, fd) \
1567 if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
1568 WaitingThreadsHd = CurrentTSO; \
1570 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1571 WaitingThreadsTl = CurrentTSO; \
1572 TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
1573 TSO_EVENT(CurrentTSO) = (W_) (-(fd)); \
1574 DO_YIELD(liveness << 1); \
1579 #define waitReadZh(liveness, fd) \
1582 fprintf(stderr, "waitRead#: unthreaded build.\n"); \
1583 EXIT(EXIT_FAILURE); \
1590 /* ToDo: something for GRAN */
1592 #ifdef HAVE_SYS_TYPES_H
1593 #include <sys/types.h>
1594 #endif HAVE_SYS_TYPES_H */
1596 #define waitWriteZh(liveness, fd) \
1598 if (WaitingThreadsTl == Prelude_Z91Z93_closure) \
1599 WaitingThreadsHd = CurrentTSO; \
1601 TSO_LINK(WaitingThreadsTl) = CurrentTSO; \
1602 WaitingThreadsTl = CurrentTSO; \
1603 TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure; \
1604 TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE)); \
1605 DO_YIELD(liveness << 1); \
1610 #define waitWriteZh(liveness, fd) \
1613 fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1614 EXIT(EXIT_FAILURE); \
1621 %************************************************************************
1623 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1625 %************************************************************************
1628 extern P_ TopClosure;
1629 EXTFUN(ErrorIO_innards);
1630 EXTFUN(__std_entry_error__);
1632 #define errorIOZh(a) \
1633 do { TopClosure=(a); \
1634 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1635 (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1636 JMP_(ErrorIO_innards); \
1639 #if !defined(CALLER_SAVES_SYSTEM)
1640 /* can use the macros */
1641 #define stg_getc(stream) getc((FILE *) (stream))
1642 #define stg_putc(c,stream) putc((c),((FILE *) (stream)))
1644 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1645 #define stg_getc(stream) SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1646 #define stg_putc(c,stream) SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1649 int initialize_virtual_timer(int us);
1650 int install_segv_handler(STG_NO_ARGS);
1651 int install_vtalrm_handler(STG_NO_ARGS);
1652 void initUserSignals(STG_NO_ARGS);
1653 void blockUserSignals(STG_NO_ARGS);
1654 void unblockUserSignals(STG_NO_ARGS);
1655 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1656 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1657 IF_RTS(void AwaitEvent(I_ delta);)
1659 #ifdef _POSIX_SOURCE
1660 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1661 #define stg_sig_ignore(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1662 #define stg_sig_default(s,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1663 #define stg_sig_catch(s,sp,m) SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1665 extern I_ sig_install PROTO((I_, I_));
1666 #define stg_sig_ignore(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1667 #define stg_sig_default(s,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1668 #define stg_sig_catch(s,sp,m) SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1671 #define STG_SIG_DFL (-1)
1672 #define STG_SIG_IGN (-2)
1673 #define STG_SIG_ERR (-3)
1675 StgInt getErrorHandler(STG_NO_ARGS);
1677 void raiseError PROTO((StgStablePtr handler));
1678 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1680 void decrementErrorCount(STG_NO_ARGS);
1682 #define stg_catchError(sp) SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1683 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1686 %************************************************************************
1688 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1690 %************************************************************************
1693 The type of these should be:
1696 makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1697 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1700 Since world-tokens are no longer explicitly passed around, the
1701 implementations have a few less arguments/results.
1703 The simpler one is @deRefStablePointer#@ (which is only a primop
1704 because it is more polymorphic than is allowed of a ccall).
1709 #define deRefStablePtrZh(ri,sp) \
1712 fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1713 EXIT(EXIT_FAILURE); \
1718 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1720 #define deRefStablePtrZh(ri,sp) \
1721 ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1724 Declarations for other stable pointer operations.
1727 void freeStablePointer PROTO((I_ stablePtr));
1729 void enterStablePtr PROTO((StgStablePtr, StgFunPtr));
1730 void performIO PROTO((StgStablePtr));
1731 I_ enterInt PROTO((StgStablePtr));
1732 I_ enterFloat PROTO((StgStablePtr));
1733 P_ deRefStablePointer PROTO((StgStablePtr));
1734 IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
1735 IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
1736 IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
1737 IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
1739 EXTFUN(stopPerformIODirectReturn);
1740 EXTFUN(startPerformIO);
1741 EXTFUN(stopEnterIntDirectReturn);
1742 EXTFUN(startEnterInt);
1743 EXTFUN(stopEnterFloatDirectReturn);
1744 EXTFUN(startEnterFloat);
1746 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1750 IF_RTS(extern I_ ErrorIO_call_count;)
1753 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1754 if we're unlucky, it will have to allocate a new table and copy the
1755 old bit over. Since we might, very occasionally, have to call the
1756 garbage collector, this has to be a macro... sigh!
1758 NB @newSP@ is required because it is entirely possible that
1759 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1760 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1762 Another obscure piece of coding is the recalculation of the size of
1763 the table. We do this just in case Jim's threads decide they want to
1764 context switch---in which case any stack-allocated variables may get
1765 trashed. (If only there was a special heap check which didn't
1766 consider context switching...)
1771 /* Calculate SP Table size from number of pointers */
1772 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1774 /* Calculate number of pointers in new table from number in old table:
1775 any strictly increasing expression will do here */
1776 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1778 void enlargeSPTable PROTO((P_, P_));
1780 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1782 EXTDATA_RO(StablePointerTable_info); \
1783 EXTDATA(UnusedSP); \
1784 StgStablePtr newSP; \
1786 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1787 { /* Variables used before the heap check */ \
1788 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1789 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1790 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1791 HEAP_CHK(liveness, _FHS+NewSize, 0); \
1793 { /* Variables used after the heap check - same values */ \
1794 I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1795 I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs ); \
1796 I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs ); \
1797 P_ SPTable = Hp + 1 - (_FHS + NewSize); \
1799 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
1800 SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1801 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
1802 StorageMgrInfo.StablePointerTable = SPTable; \
1806 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
1807 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1808 CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable ); \
1809 stablePtr = newSP; \
1814 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
1817 fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1818 EXIT(EXIT_FAILURE); \
1824 %************************************************************************
1826 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1828 %************************************************************************
1830 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1831 can expect three parameters: the two arguments and a "register" to put
1834 Message to Will: This primop breaks referential transparency so badly
1835 you might want to leave it out. On the other hand, if you hide it
1836 away in an appropriate monad, it's perfectly safe. [ADR]
1838 Note that this primop is non-deterministic: different results can be
1839 obtained depending on just what the garbage collector (and code
1840 optimiser??) has done. However, we can guarantee that if two objects
1841 are pointer-equal, they have the same denotation --- the converse most
1842 certainly doesn't hold.
1844 ToDo ADR: The degree of non-determinism could be greatly reduced by
1845 following indirections.
1848 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1851 %************************************************************************
1853 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1855 %************************************************************************
1857 Assuming local sparking in some form, we can now inline the spark request.
1859 We build a doubly-linked list in the heap, so that we can handle FIFO
1860 or LIFO scheduling as we please.
1862 Anything with tag >= 0 is in WHNF, so we discard it.
1867 ED_(Prelude_Z91Z93_closure);
1871 #define parZh(r,node) \
1872 PARZh(r,node,1,0,0,0,0,0)
1874 #define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1875 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
1877 #define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1878 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
1880 #define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1881 parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
1883 #define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1884 parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
1886 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local) \
1889 if (SHOULD_SPARK(node)) { \
1892 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local); \
1893 if (local==2) { /* special case for parAtAbs */ \
1894 GranSimSparkAtAbs(result,(I_)where,identifier);\
1895 } else if (local==3) { /* special case for parAtRel */ \
1896 GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier); \
1898 GranSimSparkAt(result,where,identifier); \
1900 context_switch = 1; \
1902 RestoreAllStgRegs(); \
1903 } else if (do_qp_prof) { \
1904 I_ tid = threadId++; \
1905 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1907 r = 1; /* return code for successful spark -- HWL */ \
1910 #define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1911 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
1913 #define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1914 PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
1918 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1920 if (SHOULD_SPARK(node)) { \
1923 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1924 add_to_spark_queue(result); \
1925 GranSimSpark(local,(P_)node); \
1926 context_switch = 1; \
1928 RestoreAllStgRegs(); \
1929 } else if (do_qp_prof) { \
1930 I_ tid = threadId++; \
1931 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1933 r = 1; /* return code for successful spark -- HWL */ \
1938 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1941 if (SHOULD_SPARK(node)) { \
1942 result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1943 ADD_TO_SPARK_QUEUE(result); \
1944 SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node); \
1945 /* context_switch = 1; not needed any more -- HWL */ \
1946 } else if (do_qp_prof) { \
1947 I_ tid = threadId++; \
1948 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1950 r = 1; /* return code for successful spark -- HWL */ \
1955 #define copyableZh(r,node) \
1956 /* copyable not yet implemented!! */
1958 #define noFollowZh(r,node) \
1959 /* noFollow not yet implemented!! */
1963 extern I_ required_thread_count;
1966 #define COUNT_SPARK TSO_GLOBALSPARKS(CurrentTSO)++
1972 Note that we must bump the required thread count NOW, rather
1973 than when the thread is actually created.
1976 #define forkZh(r,liveness,node) \
1978 while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
1979 DO_YIELD((liveness << 1) | 1); \
1981 if (SHOULD_SPARK(node)) { \
1982 *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node); \
1983 } else if (DO_QP_PROF) { \
1984 I_ tid = threadId++; \
1985 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
1987 required_thread_count++; \
1988 context_switch = 1; \
1989 r = 1; /* Should not be necessary */ \
1992 #define parZh(r,node) \
1995 if (SHOULD_SPARK(node) && \
1996 PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
1997 *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
2001 I_ tid = threadId++; \
2002 SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
2005 r = 1; /* Should not be necessary */ \
2011 The following seq# code should only be used in unoptimized code.
2012 Be warned: it's a potential bug-farm.
2014 First we push two words on the B stack: the current value of RetReg
2015 (which may or may not be live), and a continuation snatched largely out
2016 of thin air (it's a point within this code block). Then we set RetReg
2017 to the special polymorphic return code for seq, load up Node with the
2018 closure to be evaluated, and we're off. When the eval returns to the
2019 polymorphic seq return point, the two words are popped off the B stack,
2020 RetReg is restored, and we jump to the continuation, completing the
2021 primop and going on our merry way.
2027 #define seqZh(r,liveness,node) \
2030 /* STK_CHK(liveness,0,2,0,0,0,0); */ \
2031 /* SpB -= BREL(2); */ \
2032 SpB[BREL(0)] = (W_) RetReg; \
2033 SpB[BREL(1)] = (W_) &&cont; \
2034 RetReg = (StgRetAddr) vtbl_seq; \
2037 InfoPtr = (D_)(INFO_PTR(Node)); \
2038 JMP_(ENTRY_CODE(InfoPtr)); \
2040 r = 1; /* Should be unnecessary */ \
2043 #endif /* CONCURRENT */
2046 %************************************************************************
2048 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2050 %************************************************************************
2052 [Based on previous MallocPtr comments -- SOF]
2054 This macro is used to construct a ForeignObj on the heap.
2056 What this does is plug the pointer (which will be in a local
2057 variable) together with its finalising/free routine, into a fresh heap
2058 object and then sets a result (which will be a register) to point
2059 to the fresh heap object.
2061 To accommodate per-object finalisation, augment the macro with a
2062 finalisation routine argument. Nothing spectacular, just plug the
2063 pointer to the routine into the ForeignObj -- SOF 4/96
2065 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2066 too? (It's if you want to use the SPAT profiling tools to
2067 characterize program behavior by ``activity'' -- tail-calling,
2068 heap-checking, etc. -- see Ticky.lh. It is quite specialized.
2071 (Swapped first two arguments to make it come into line with what appears
2072 to be `standard' format, return register then liveness mask. -- SOF 4/96)
2077 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2079 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2083 HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0); \
2084 CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */ \
2086 result = Hp + 1 - (_FHS + ForeignObj_SIZE); \
2087 SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
2088 ForeignObj_CLOSURE_DATA(result) = (P_)mptr; \
2089 ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise; \
2090 ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
2091 StorageMgrInfo.ForeignObjList = result; \
2094 printf("DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \
2096 result[0],result[1], \
2097 result[2],result[3]); \
2099 CHECK_ForeignObj_CLOSURE( result ); \
2100 VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2102 (r) = (P_) result; \
2106 #define makeForeignObjZh(r, liveness, mptr, finalise) \
2109 fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2110 EXIT(EXIT_FAILURE); \
2117 End-of-file's multi-slurp protection:
2119 #endif /* ! STGMACROS_H */