ghc/includes/StgMacros.lh

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
   3 %
   4 \section[StgMacros]{C macros used in GHC-generated \tr{.hc} files}
   5
   6 \begin{code}
   7 #ifndef STGMACROS_H
   8 #define STGMACROS_H
   9 \end{code}
  10
  11 %************************************************************************
  12 %*                                                                      *
  13 \subsection[StgMacros-abbrev]{Abbreviatory(?) and general macros}
  14 %*                                                                      *
  15 %************************************************************************
  16
  17 Mere abbreviations:
  18 \begin{code}
  19 /* for function declarations */
  20 #define STGFUN(f)  F_ f(STG_NO_ARGS)
  21 #define STATICFUN(f) static F_ f(STG_NO_ARGS)
  22
  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 */
  27
  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 */
  33
  34 /* short forms of most of the above */
  35
  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)
  42
  43 /* GCC is uncooperative about the next one: */
  44 /* But, the "extern" prevents initialisation... ADR */
  45 #if defined(__GNUC__)
  46 #define ID_(d)          extern W_ d[]
  47 #define ID_RO_(d)       extern const W_ d[] /* read-only */
  48 #else
  49 #define ID_(d)          static W_ d[]
  50 #define ID_RO_(d)       static const W_ d[] /* read-only */
  51 #endif /* not GCC */
  52 \end{code}
  53
  54 General things; note: general-but-``machine-dependent'' macros are
  55 given in \tr{StgMachDeps.lh}.
  56 \begin{code}
  57 I_ STG_MAX PROTO((I_, I_)); /* GCC -Wall loves prototypes */
  58
  59 extern STG_INLINE
  60 I_
  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.
  65 */
  66
  67 /*
  68 Macros to combine two short words into a single
  69 word and split such a word back into two.
  70
  71 Dependent on machine word size :-)
  72 */
  73
  74 #define COMBINE_WORDS(word,short1,short2)               \
  75         do {                                            \
  76             ((packed_shorts *)&(word))->wu.s1 = short1; \
  77             ((packed_shorts *)&(word))->wu.s2 = short2; \
  78         } while(0)
  79
  80 #define SPLIT_WORD(word,short1,short2)                  \
  81         do {                                            \
  82             short1 = ((packed_shorts *)&(word))->wu.s1; \
  83             short2 = ((packed_shorts *)&(word))->wu.s2; \
  84         } while(0)
  85
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection[StgMacros-gen-stg]{General STGish macros}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 Common sizes of vector-return tables.
  95
  96 Claim: don't need fwd decls for return pts in \tr{VECTBL*}, because
  97 the AbsC flattener ensures that things come out sufficiently
  98 ``backwards''.
  99
 100 \begin{code}
 101 #ifdef __STG_REV_TBLS__
 102 #define UNVECTBL(staticp,label,a)   /* nothing */
 103 #else
 104 #define UNVECTBL(staticp,label,a) \
 105 EXTFUN(a); \
 106 staticp const W_ label[] = { \
 107   (W_) a \
 108 };
 109 #endif
 110 \end{code}
 111
 112 \begin{code}
 113 #if defined(USE_SPLIT_MARKERS)
 114 #define __STG_SPLIT_MARKER(n) FN_(CAT2(__stg_split_marker,n)){ }
 115 #else
 116 #define __STG_SPLIT_MARKER(n) /* nothing */
 117 #endif
 118 \end{code}
 119
 120 %************************************************************************
 121 %*                                                                      *
 122 \subsection[StgMacros-exceptions]{Exception-checking macros}
 123 %*                                                                      *
 124 %************************************************************************
 125
 126 Argument-satisfaction check, stack(s) overflow check, heap overflow
 127 check.
 128
 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.
 131
 132 \begin{code}
 133 #define SUBTRACT_A_STK( upper, lower ) AREL( (lower) - (upper) )
 134 #define SUBTRACT_B_STK( upper, lower ) BREL( (lower) - (upper) )
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsubsection[StgMacros-arg-satis]{Argument-satisfaction checks}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 @ARGS_CHK(n)@ sees of there are @n@ words of args on the A/B stack.
 144 If not, it jumps to @UpdatePAP@.
 145
 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)
 149 than (x-a < n).
 150
 151 \begin{code}
 152 #define ARGS_CHK_A(n)                                           \
 153         if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) {   \
 154                 JMP_( UpdatePAP );                              \
 155         }
 156
 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;                       \
 160                 JMP_( UpdatePAP );                              \
 161         }
 162
 163 #define ARGS_CHK_B(n)                                           \
 164         if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) {   \
 165                 JMP_( UpdatePAP );                              \
 166         }
 167
 168
 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;                       \
 172                 JMP_( UpdatePAP );                              \
 173         }
 174 \end{code}
 175
 176 %************************************************************************
 177 %*                                                                      *
 178 \subsubsection[StgMacros-stk-chks]{Stack-overflow check}
 179 %*                                                                      *
 180 %************************************************************************
 181
 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).
 185
 186 (It will be different in the parallel case.)
 187
 188 NB: args @a@ and @b@ are pre-direction-ified!
 189 \begin{code}
 190 I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
 191 int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
 192
 193 #if ! defined(CONCURRENT)
 194
 195 extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
 196
 197 #if STACK_CHECK_BY_PAGE_FAULT
 198
 199 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter)  \
 200     /* use memory protection instead; still need ticky-ness */
 201
 202 #else
 203
 204 #define STACK_OVERFLOW(liveness,hda,hdb,spa,spb,rtype,reenter)  \
 205     ULTRASAFESTGCALL0(void,(void *),StackOverflow)
 206
 207 #endif /* not using page-faulting */
 208
 209 #else /* threaded */
 210
 211 I_ StackOverflow PROTO((W_, W_));
 212
 213 /*
 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.
 216  */
 217
 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))
 220
 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)
 224
 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)
 228
 229 #endif  /* CONCURRENT */
 230
 231 #define STK_CHK(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter)\
 232 do {                                                            \
 233   DO_ASTK_HWM(); /* ticky-ticky profiling */                    \
 234   DO_BSTK_HWM();                                                \
 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);\
 237   }                                                             \
 238 }while(0)
 239 \end{code}
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 \subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 Please see the general discussion/commentary about ``what really
 248 happens in a GC,'' in \tr{SMinterface.lh}.
 249
 250 \begin{code}
 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);
 254
 255 #ifndef PAR
 256 void StgPerformGarbageCollection(STG_NO_ARGS);
 257 #endif
 258
 259 #ifndef CONCURRENT
 260
 261 #define OR_MSG_PENDING  /* never */
 262
 263 #define HEAP_OVERFLOW(liveness,n,reenter)       \
 264     do {                                        \
 265     DO_GC((((W_)n)<<8)|(liveness));             \
 266     } while (0)
 267
 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)
 272
 273 #else /* CONCURRENT */
 274
 275 void ReallyPerformThreadGC PROTO((W_, rtsBool));
 276
 277 #define HEAP_OVERFLOW(liveness,n,reenter)       \
 278     do {                                        \
 279     DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
 280     } while (0)
 281
 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)
 286
 287 #ifndef PAR
 288
 289 #define OR_MSG_PENDING  /* never */
 290
 291 #else
 292
 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 */
 298
 299 #endif  /* PAR */
 300 #endif  /* CONCURRENT */
 301
 302 #if 0 /* alpha_TARGET_ARCH */
 303 #define CACHE_LINE  4   /* words */
 304 #define LINES_AHEAD 3
 305 #define PRE_FETCH(n)                                    \
 306 do {                                                    \
 307  StgInt j;                                              \
 308  j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE];    \
 309 } while(0);
 310 #define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
 311 #else
 312 #define PRE_FETCH(reg)
 313 #define EXTRA_HEAP_WORDS 0
 314 #endif
 315
 316 #if defined(GRAN)
 317 #define HEAP_CHK(liveness_mask,n,reenter)                       \
 318         do {                                                    \
 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); \
 326         }}while(0)
 327
 328 #else
 329
 330 #define HEAP_CHK(liveness_mask,n,reenter)               \
 331 do {                                                    \
 332   /* TICKY_PARANOIA(__FILE__, __LINE__); */             \
 333   PRE_FETCH(n);                                         \
 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);             \
 337   }                                                     \
 338 } while(0)
 339
 340 #endif  /* GRAN */
 341
 342 #ifdef CONCURRENT
 343
 344 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
 345 do {                                                    \
 346   /* TICKY_PARANOIA(__FILE__, __LINE__); */             \
 347   PRE_FETCH(n);                                         \
 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);                           \
 352   }} while(0)
 353
 354 #else
 355
 356 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter)     \
 357     HEAP_CHK(liveness_mask,n,reenter)
 358
 359 #endif
 360
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection[StgMacros-prim-ops]{Primitive operations}
 367 %*                                                                      *
 368 %************************************************************************
 369
 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!)
 374
 375 The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 We cast the chars in case one of them is a literal (so C things work right
 384 even for 8-bit chars).
 385 \begin{code}
 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))
 392
 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))
 399
 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))
 406
 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))
 413
 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))
 420
 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))
 427 \end{code}
 428
 429 %************************************************************************
 430 %*                                                                      *
 431 \subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
 432 %*                                                                      *
 433 %************************************************************************
 434
 435 We cast the chars in case one of them is a literal (so C things work right
 436 even for 8-bit chars).
 437 \begin{code}
 438 #define ordZh(r,a)      r=(I_)((W_) (a))
 439 #define chrZh(r,a)      r=(StgChar)((W_)(a))
 440 \end{code}
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 \begin{code}
 449 I_ stg_div PROTO((I_ a, I_ b));
 450
 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)
 458 \end{code}
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 \begin{code}
 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)
 470
 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)
 477
 478 #define int2WordZh(r,a) r=(W_)(a)
 479 #define word2IntZh(r,a) r=(I_)(a)
 480 \end{code}
 481
 482 %************************************************************************
 483 %*                                                                      *
 484 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
 485 %*                                                                      *
 486 %************************************************************************
 487
 488 \begin{code}
 489 #define int2AddrZh(r,a) r=(A_)(a)
 490 #define addr2IntZh(r,a) r=(I_)(a)
 491 \end{code}
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 \begin{code}
 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)
 505
 506 #define int2FloatZh(r,a)        r=(StgFloat)(a)
 507 #define float2IntZh(r,a)        r=(I_)(a)
 508
 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)
 522
 523 /* encoding/decoding given w/ Integer stuff */
 524 \end{code}
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 \begin{code}
 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)
 538
 539 #define int2DoubleZh(r,a)       r=(StgDouble)(a)
 540 #define double2IntZh(r,a)       r=(I_)(a)
 541
 542 #define float2DoubleZh(r,a)     r=(StgDouble)(a)
 543 #define double2FloatZh(r,a)     r=(StgFloat)(a)
 544
 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)
 558 \end{code}
 559
 560 %************************************************************************
 561 %*                                                                      *
 562 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
 563 %*                                                                      *
 564 %************************************************************************
 565
 566 Dirty macros we use for the real business.
 567
 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}).
 572
 573 OK, here are the real macros:
 574 \begin{code}
 575 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da)   \
 576 { MP_INT arg;                                                                   \
 577   MP_INT result;                                                                \
 578   I_ space = size_chk_macro(sa);                                                \
 579                                                                                 \
 580   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 581   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 582                                                                                 \
 583   /* Now we can initialise (post possible GC) */                                \
 584   arg.alloc     = (aa);                                                         \
 585   arg.size      = (sa);                                                         \
 586   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da));                     \
 587                                                                                 \
 588   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result);                       \
 589                                                                                 \
 590   /* Perform the operation */                                                   \
 591   SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg);          \
 592                                                                                 \
 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) */ \
 598 }
 599
 600
 601 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
 602 { MP_INT arg1;                                                                  \
 603   MP_INT arg2;                                                                  \
 604   MP_INT result;                                                                \
 605   I_ space = size_chk_macro(s1,s2);                                             \
 606                                                                                 \
 607   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 608   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 609                                                                                 \
 610   /* Now we can initialise (post possible GC) */                                \
 611   arg1.alloc    = (a1);                                                         \
 612   arg1.size     = (s1);                                                         \
 613   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 614   arg2.alloc    = (a2);                                                         \
 615   arg2.size     = (s2);                                                         \
 616   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 617                                                                                 \
 618   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result);                       \
 619                                                                                 \
 620   /* Perform the operation */                                                   \
 621   SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
 622                                                                                 \
 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) */ \
 628 }
 629
 630 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
 631 { MP_INT arg1;                                                                  \
 632   MP_INT arg2;                                                                  \
 633   MP_INT result1;                                                               \
 634   MP_INT result2;                                                               \
 635   I_ space = size_chk_macro(s1,s2);                                             \
 636                                                                                 \
 637   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 638   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 639                                                                                 \
 640   /* Now we can initialise (post possible GC) */                                \
 641   arg1.alloc    = (a1);                                                         \
 642   arg1.size     = (s1);                                                         \
 643   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 644   arg2.alloc    = (a2);                                                         \
 645   arg2.size     = (s2);                                                         \
 646   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 647                                                                                 \
 648   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1);                      \
 649   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2);                      \
 650                                                                                 \
 651   /* Perform the operation */                                                   \
 652   SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
 653                                                                                 \
 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);                                           \
 661 }
 662 \end{code}
 663
 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
 667 in their ``size''...
 668 \begin{code}
 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 */
 677 \end{code}
 678
 679 For the Integer/GMP stuff, we have macros that {\em look ahead} for
 680 some space, but don't actually grab it.
 681
 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.
 688
 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.
 692
 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
 695 threaded land.
 696
 697 \begin{code}
 698 #define GMP_HEAP_LOOKAHEAD(liveness,n)                  \
 699         do {                                            \
 700         HEAP_CHK_AND_RESTORE_N(liveness,n,0);           \
 701         Hp = Hp - (n);                                  \
 702         UN_ALLOC_HEAP(n);       /* Undo ticky-ticky */  \
 703         SAVE_Hp = Hp;           /* Hand over the hp */  \
 704         DEBUG_SetGMPAllocBudget(n)                      \
 705         }while(0)
 706
 707 #define GMP_HEAP_HANDBACK()                             \
 708         Hp = SAVE_Hp;                                   \
 709         DEBUG_ResetGMPAllocBudget()
 710 \end{code}
 711
 712 \begin{code}
 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));
 716
 717 #ifdef ALLOC_DEBUG
 718 extern StgInt DEBUG_GMPAllocBudget;
 719 #define DEBUG_SetGMPAllocBudget(n)  DEBUG_GMPAllocBudget = (n);
 720 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
 721 #else
 722 #define DEBUG_SetGMPAllocBudget(n)  /*nothing*/
 723 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
 724 #endif
 725 \end{code}
 726
 727 The real business (defining Integer primops):
 728 \begin{code}
 729 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
 730         gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
 731
 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)
 738
 739 /* div, mod, quot, rem are defined w/ quotRem & divMod */
 740
 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)
 745 \end{code}
 746
 747 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
 748 fellow (returns -ve, 0, or +ve).
 749 \begin{code}
 750 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */             \
 751 { MP_INT arg1;                                                                  \
 752   MP_INT arg2;                                                                  \
 753   /* Does not allocate memory */                                                \
 754                                                                                 \
 755   arg1.alloc    = (a1);                                                         \
 756   arg1.size     = (s1);                                                         \
 757   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 758   arg2.alloc    = (a2);                                                         \
 759   arg2.size     = (s2);                                                         \
 760   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 761                                                                                 \
 762   (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2);      \
 763 }
 764 \end{code}
 765
 766 Coercions:
 767
 768 \begin{code}
 769 #define integer2IntZh(r, hp, aa,sa,da)                                          \
 770 { MP_INT arg;                                                                   \
 771   /* Does not allocate memory */                                                \
 772                                                                                 \
 773   arg.alloc     = (aa);                                                         \
 774   arg.size      = (sa);                                                         \
 775   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da));                     \
 776                                                                                 \
 777   (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg);                    \
 778 }
 779
 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! ***
 783 */
 784
 785 #define int2IntegerZh(ar,sr,dr, hp, i)                                          \
 786 { StgInt val; /* to snaffle arg to avoid aliasing */                            \
 787                                                                                 \
 788   val = (i);  /* snaffle... */                                                  \
 789                                                                                 \
 790   SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);           \
 791                                                                                 \
 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; }                                            \
 795   (ar) = 1;                                                                     \
 796   (dr) = (B_)(hp);              /* dr is an StgByteArray */                     \
 797 }
 798
 799 #define word2IntegerZh(ar,sr,dr, hp, i)                                         \
 800 { StgWord val; /* to snaffle arg to avoid aliasing */                           \
 801                                                                                 \
 802   val = (i);  /* snaffle... */                                                  \
 803                                                                                 \
 804   SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);           \
 805                                                                                 \
 806   if ((val) != 0)     { (sr) =  1; (hp)[DATA_HS] =  (val); }                    \
 807   else /* val==0 */   { (sr) =  0; }                                            \
 808   (ar) = 1;                                                                     \
 809   (dr) = (B_)(hp);              /* dr is an StgByteArray */                     \
 810 }
 811
 812 \end{code}
 813
 814 Then there are a few oddments to make life easier:
 815 \begin{code}
 816 /*
 817    DIRE WARNING.
 818    The "str" argument must be a literal C string.
 819
 820         addr2Integer( ..., "foo")   OK!
 821
 822         x = "foo";
 823         addr2Integer( ..., x)       NO! NO!
 824 */
 825
 826 #define addr2IntegerZh(ar,sr,dr, liveness, str)                                 \
 827 { MP_INT result;                                                                \
 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);                                \
 831                                                                                 \
 832   GMP_HEAP_LOOKAHEAD(liveness, space);                                          \
 833                                                                                 \
 834   /* Perform the operation */                                                   \
 835   if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
 836       abort();                                                                  \
 837                                                                                 \
 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) */ \
 843 }
 844 \end{code}
 845
 846 Encoding and decoding float-ish things is pretty Integer-ish.  We use
 847 these pretty magical support functions, essentially stolen from Lennart:
 848 \begin{code}
 849 StgFloat  __encodeFloat  PROTO((MP_INT *, I_));
 850 void      __decodeFloat  PROTO((MP_INT * /*result1*/,
 851                                 I_ * /*result2*/,
 852                                 StgFloat));
 853
 854 StgDouble __encodeDouble PROTO((MP_INT *, I_));
 855 void      __decodeDouble PROTO((MP_INT * /*result1*/,
 856                                 I_ * /*result2*/,
 857                                 StgDouble));
 858 \end{code}
 859
 860 Some floating-point format info, made with the \tr{enquire} program
 861 (version~4.3) [comes with gcc].
 862 \begin{code}
 863 /* this should be done by CPU architecture, insofar as possible [WDP] */
 864
 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
 873
 874 /* yes, it is IEEE floating point */
 875 #include "ieee-flpt.h"
 876
 877 #if alpha_dec_osf1_TARGET       \
 878  || i386_TARGET_ARCH            \
 879  || mipsel_TARGET_ARCH
 880
 881 #undef BIGENDIAN /* little-endian weirdos... */
 882 #else
 883 #define BIGENDIAN 1
 884 #endif
 885
 886 #else /* unknown floating-point format */
 887
 888 ******* ERROR *********** Any ideas about floating-point format?
 889
 890 #endif /* unknown floating-point */
 891 \end{code}
 892
 893 \begin{code}
 894 #if alpha_dec_osf1_TARGET
 895 #define encodeFloatZh(r, hp, aa,sa,da, expon)   encodeDoubleZh(r, hp, aa,sa,da, expon)
 896 #else
 897 #define encodeFloatZh(r, hp, aa,sa,da, expon)   \
 898 { MP_INT arg;                                   \
 899   /* Does not allocate memory */                \
 900                                                 \
 901   arg.alloc     = aa;                           \
 902   arg.size      = sa;                           \
 903   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 904                                                 \
 905   r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon));        \
 906 }
 907 #endif /* ! alpha */
 908
 909 #define encodeDoubleZh(r, hp, aa,sa,da, expon)  \
 910 { MP_INT arg;                                   \
 911   /* Does not allocate memory */                \
 912                                                 \
 913   arg.alloc     = aa;                           \
 914   arg.size      = sa;                           \
 915   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 916                                                 \
 917   r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
 918 }
 919
 920 #if alpha_dec_osf1_TARGET
 921 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)  decodeDoubleZh(exponr, ar,sr,dr, hp, f)
 922 #else
 923 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)                          \
 924 { MP_INT mantissa;                                                      \
 925   I_ exponent;                                                          \
 926   StgFloat arg = (f);                                                   \
 927                                                                         \
 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;                                          \
 932                                                                         \
 933   /* Perform the operation */                                           \
 934   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg);          \
 935   exponr= exponent;                                                     \
 936   ar    = mantissa.alloc;                                               \
 937   sr    = mantissa.size;                                                \
 938   dr    = (B_)(hp);                                                     \
 939 }
 940 #endif /* !alpha */
 941
 942 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f)                         \
 943 { MP_INT mantissa;                                                      \
 944   I_ exponent;                                                          \
 945   StgDouble arg = (f);                                                  \
 946                                                                         \
 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;                                          \
 951                                                                         \
 952   /* Perform the operation */                                           \
 953   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg);                \
 954   exponr= exponent;                                                     \
 955   ar    = mantissa.alloc;                                               \
 956   sr    = mantissa.size;                                                \
 957   dr    = (B_)(hp);                                                     \
 958 }
 959 \end{code}
 960
 961 %************************************************************************
 962 %*                                                                      *
 963 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
 964 %*                                                                      *
 965 %************************************************************************
 966
 967 With GCC, we use magic non-standard inlining; for other compilers, we
 968 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
 969
 970 (The @OMIT_...@ is only used in compiling some of the RTS, none of
 971 which uses these anyway.)
 972
 973 \begin{code}
 974 #if alpha_TARGET_ARCH   \
 975  || i386_TARGET_ARCH    \
 976  || m68k_TARGET_ARCH
 977
 978 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
 979 #define PK_FLT(src) (*(StgFloat *)(src))
 980
 981 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
 982 #define PK_DBL(src) (*(StgDouble *)(src))
 983
 984 #else   /* not m68k || alpha || i[34]86 */
 985
 986 /* Special handling for machines with troublesome alignment constraints */
 987
 988 #define FLOAT_ALIGNMENT_TROUBLES    TRUE
 989
 990 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
 991
 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_ []));
 996
 997 #else /* yes, its __GNUC__ && we really want them */
 998
 999 #if sparc_TARGET_ARCH
1000
1001 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1002 #define PK_FLT(src) (*(StgFloat *)(src))
1003
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));
1007
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; \
1012     } )
1013
1014 #else /* ! sparc */
1015
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_ []));
1021
1022 extern STG_INLINE
1023 void
1024 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1025 {
1026     double_thing y;
1027     y.d = src;
1028     p_dest[0] = y.du.dhi;
1029     p_dest[1] = y.du.dlo;
1030 }
1031
1032 /* GCC also works with this version, but it generates
1033    the same code as the previous one, and is not ANSI
1034
1035 #define ASSIGN_DBL( p_dest, src ) \
1036         *p_dest = ((double_thing) src).du.dhi; \
1037         *(p_dest+1) = ((double_thing) src).du.dlo \
1038 */
1039
1040 extern STG_INLINE
1041 StgDouble
1042 PK_DBL(W_ p_src[])
1043 {
1044     double_thing y;
1045     y.du.dhi = p_src[0];
1046     y.du.dlo = p_src[1];
1047     return(y.d);
1048 }
1049
1050 extern STG_INLINE
1051 void
1052 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1053 {
1054     float_thing y;
1055     y.f = src;
1056     *p_dest = y.fu;
1057 }
1058
1059 extern STG_INLINE
1060 StgFloat
1061 PK_FLT(W_ p_src[])
1062 {
1063     float_thing y;
1064     y.fu = *p_src;
1065     return(y.f);
1066 }
1067
1068 #endif /* ! sparc */
1069
1070 #endif /* __GNUC__ */
1071
1072 #endif /* not __m68k__ */
1073 \end{code}
1074
1075 %************************************************************************
1076 %*                                                                      *
1077 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1078 %*                                                                      *
1079 %************************************************************************
1080
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).
1084
1085 BYTE_ARR_CTS returns a @C_ *@!
1086
1087 We {\em ASSUME} we can use the same macro for both!!
1088 \begin{code}
1089
1090 #ifdef DEBUG
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);} )
1098 #else
1099 #define BYTE_ARR_CTS(a)         ((char *) (((StgPtr) (a))+DATA_HS))
1100 #define PTRS_ARR_CTS(a)         ((a)+MUTUPLE_HS)
1101 #endif
1102
1103 /* sigh */
1104 extern I_ genSymZh(STG_NO_ARGS);
1105 extern I_ resetGenSymZh(STG_NO_ARGS);
1106 extern I_ incSeqWorldZh(STG_NO_ARGS);
1107
1108 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1109 \end{code}
1110
1111 OK, the easy ops first: (all except \tr{newArr*}:
1112
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.
1119
1120 EVEN MORE IMPORTANT! The above is a lie.  The offsets for BlahArrays
1121 are in Blahs.  WDP 95/08
1122
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 *}.
1125
1126 In the case of @Array#@ (which contain pointers), the offset is in units
1127 of one ptr (not bytes).
1128
1129 \begin{code}
1130 #define sameMutableArrayZh(r,a,b)       r=(I_)((a)==(b))
1131 #define sameMutableByteArrayZh(r,a,b)   r=(I_)((B_)(a)==(B_)(b))
1132
1133 #define readArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1134
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)
1140
1141 /* result ("r") arg ignored in write macros! */
1142 #define writeArrayZh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1143
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)
1151
1152 #define indexArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1153
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)
1159
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))
1165
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)                                \
1171         do {                                            \
1172         P_ result;                                      \
1173         result=(P_) (a);                                \
1174         FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info);   \
1175         r = result;                                     \
1176         }while(0)
1177
1178 #define unsafeFreezeByteArrayZh(r,a)    r=(B_)(a)
1179 \end{code}
1180
1181 Now the \tr{newArr*} ops:
1182
1183 \begin{code}
1184 /*
1185 --------------------
1186 Will: ToDo: we need to find suitable places to put this comment, and the
1187 "in-general" one which follows.
1188
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.
1193
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 ------------------------
1198
1199 NOTE: the above may now be OLD (WDP 94/02/10)
1200 */
1201 \end{code}
1202
1203 For char arrays, the size is in {\em BYTES}.
1204
1205 \begin{code}
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))
1211
1212 #define newByteArray(r,liveness,n)                              \
1213 {                                                               \
1214   P_ result;                                                    \
1215   I_ size;                                                      \
1216                                                                 \
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);                             \
1221                                                                 \
1222   result = Hp-(DATA_HS+size)+1;                                 \
1223   SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0);    \
1224   r = (B_) result;                                              \
1225 }
1226 \end{code}
1227
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.
1232
1233 \begin{code}
1234 /* The new array initialization routine for the NCG */
1235 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1236
1237 #define newArrayZh(r,liveness,n,init)                   \
1238 {                                                       \
1239   P_ p;                                                 \
1240   P_ result;                                            \
1241                                                         \
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 */     \
1245                                                         \
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++) { \
1249         *p = (W_) (init);                               \
1250   }                                                     \
1251                                                         \
1252   r = result;                                           \
1253 }
1254 \end{code}
1255
1256 %************************************************************************
1257 %*                                                                      *
1258 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1259 %*                                                                      *
1260 %************************************************************************
1261
1262 \begin{code}
1263 ED_(Prelude_Z91Z93_closure);
1264
1265 #define newSynchVarZh(r, hp)                            \
1266 {                                                       \
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;      \
1271   r = hp;                                               \
1272 }
1273 \end{code}
1274
1275 \begin{code}
1276 #ifdef CONCURRENT
1277
1278 void Yield PROTO((W_));
1279
1280 #define takeMVarZh(r, liveness, node)                   \
1281 {                                                       \
1282   while (INFO_PTR(node) != (W_) FullSVar_info) {        \
1283     if (SVAR_HEAD(node) == Prelude_Z91Z93_closure)              \
1284       SVAR_HEAD(node) = CurrentTSO;                     \
1285     else                                                \
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);                            \
1290   }                                                     \
1291   SET_INFO_PTR(node, EmptySVar_info);                   \
1292   r = SVAR_VALUE(node);                                 \
1293   SVAR_VALUE(node) = Prelude_Z91Z93_closure;                    \
1294 }
1295
1296 #else
1297
1298 #define takeMVarZh(r, liveness, node)                   \
1299 {                                                       \
1300   if (INFO_PTR(node) != (W_) FullSVar_info) {           \
1301     /* Don't wrap the calls; we're done with STG land */\
1302     fflush(stdout);                                     \
1303     fprintf(stderr, "takeMVar#: MVar is empty.\n");     \
1304     EXIT(EXIT_FAILURE);                                 \
1305   }                                                     \
1306   SET_INFO_PTR(node, EmptySVar_info);                   \
1307   r = SVAR_VALUE(node);                                 \
1308   SVAR_VALUE(node) = Prelude_Z91Z93_closure;                    \
1309 }
1310
1311 #endif
1312 \end{code}
1313
1314 \begin{code}
1315 #ifdef CONCURRENT
1316
1317 #ifdef GRAN
1318
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 */
1323
1324 #define putMVarZh(node, value)                          \
1325 {                                                       \
1326   P_ tso;                                               \
1327   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1328     /* Don't wrap the calls; we're done with STG land */\
1329     fflush(stdout);                                     \
1330     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1331     EXIT(EXIT_FAILURE);                                 \
1332   }                                                     \
1333   SET_INFO_PTR(node, FullSVar_info);                    \
1334   SVAR_VALUE(node) = value;                             \
1335   tso = SVAR_HEAD(node);                                \
1336   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1337     if (DO_QP_PROF)                                     \
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;                      \
1341     else                                                \
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;            \
1348   }                                                     \
1349 }
1350
1351 #else /* !GRAN */
1352
1353 #define putMVarZh(node, value)                          \
1354 {                                                       \
1355   P_ tso;                                               \
1356   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1357     /* Don't wrap the calls; we're done with STG land */\
1358     fflush(stdout);                                     \
1359     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1360     EXIT(EXIT_FAILURE);                                 \
1361   }                                                     \
1362   SET_INFO_PTR(node, FullSVar_info);                    \
1363   SVAR_VALUE(node) = value;                             \
1364   tso = SVAR_HEAD(node);                                \
1365   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1366     if (DO_QP_PROF)                                     \
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;                          \
1370     else                                                \
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;            \
1377   }                                                     \
1378 }
1379
1380 #endif  /* GRAN */
1381
1382 #else
1383
1384 #define putMVarZh(node, value)                          \
1385 {                                                       \
1386   P_ tso;                                               \
1387   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1388     /* Don't wrap the calls; we're done with STG land */\
1389     fflush(stdout);                                     \
1390     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1391     EXIT(EXIT_FAILURE);                                 \
1392   }                                                     \
1393   SET_INFO_PTR(node, FullSVar_info);                    \
1394   SVAR_VALUE(node) = value;                             \
1395 }
1396
1397 #endif
1398 \end{code}
1399
1400 \begin{code}
1401 #ifdef CONCURRENT
1402
1403 #define readIVarZh(r, liveness, node)                   \
1404 {                                                       \
1405   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1406     if (SVAR_HEAD(node) == Prelude_Z91Z93_closure)              \
1407       SVAR_HEAD(node) = CurrentTSO;                     \
1408     else                                                \
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);                            \
1413   }                                                     \
1414   r = SVAR_VALUE(node);                                 \
1415 }
1416
1417 #else
1418
1419 #define readIVarZh(r, liveness, node)                   \
1420 {                                                       \
1421   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1422     /* Don't wrap the calls; we're done with STG land */\
1423     fflush(stdout);                                     \
1424     fprintf(stderr, "readIVar#: IVar is empty.\n");     \
1425     EXIT(EXIT_FAILURE);                                 \
1426   }                                                     \
1427   r = SVAR_VALUE(node);                                 \
1428 }
1429
1430 #endif
1431 \end{code}
1432
1433 \begin{code}
1434 #ifdef CONCURRENT
1435
1436 #ifdef GRAN
1437
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 */
1442
1443 #define writeIVarZh(node, value)                        \
1444 {                                                       \
1445   P_ tso;                                               \
1446   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1447     /* Don't wrap the calls; we're done with STG land */\
1448     fflush(stdout);                                     \
1449     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1450     EXIT(EXIT_FAILURE);                                 \
1451   }                                                     \
1452   tso = SVAR_HEAD(node);                                \
1453   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1454     if (ThreadQueueHd == Prelude_Z91Z93_closure)                \
1455       ThreadQueueHd = tso;                      \
1456     else                                                \
1457       TSO_LINK(ThreadQueueTl) = tso;            \
1458     while(TSO_LINK(tso) != Prelude_Z91Z93_closure) {            \
1459       if (DO_QP_PROF)                                   \
1460         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1461       tso = TSO_LINK(tso);                              \
1462     }                                                   \
1463     if (DO_QP_PROF)                                     \
1464       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1465     ThreadQueueTl = tso;                                \
1466   }                                                     \
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;                             \
1471 }
1472
1473 #else /* !GRAN */
1474
1475 #define writeIVarZh(node, value)                        \
1476 {                                                       \
1477   P_ tso;                                               \
1478   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1479     /* Don't wrap the calls; we're done with STG land */\
1480     fflush(stdout);                                     \
1481     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1482     EXIT(EXIT_FAILURE);                                 \
1483   }                                                     \
1484   tso = SVAR_HEAD(node);                                \
1485   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1486     if (RunnableThreadsHd == Prelude_Z91Z93_closure)            \
1487       RunnableThreadsHd = tso;                          \
1488     else                                                \
1489       TSO_LINK(RunnableThreadsTl) = tso;                \
1490     while(TSO_LINK(tso) != Prelude_Z91Z93_closure) {            \
1491       if (DO_QP_PROF)                                   \
1492         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1493       tso = TSO_LINK(tso);                              \
1494     }                                                   \
1495     if (DO_QP_PROF)                                     \
1496       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1497     RunnableThreadsTl = tso;                            \
1498   }                                                     \
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;                             \
1503 }
1504
1505 #endif  /* GRAN */
1506
1507 #else
1508
1509 #define writeIVarZh(node, value)                        \
1510 {                                                       \
1511   P_ tso;                                               \
1512   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1513     /* Don't wrap the calls; we're done with STG land */\
1514     fflush(stdout);                                     \
1515     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1516     EXIT(EXIT_FAILURE);                                 \
1517   }                                                     \
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;                             \
1522 }
1523
1524 #endif
1525 \end{code}
1526
1527 %************************************************************************
1528 %*                                                                      *
1529 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1530 %*                                                                      *
1531 %************************************************************************
1532
1533 \begin{code}
1534 #ifdef CONCURRENT
1535
1536 /* ToDo: for GRAN */
1537
1538 #define delayZh(liveness, us)                           \
1539   {                                                     \
1540     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1541       WaitingThreadsHd = CurrentTSO;                    \
1542     else                                                \
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);                            \
1548   }
1549
1550 #else
1551
1552 #define delayZh(liveness, us)                           \
1553   {                                                     \
1554     fflush(stdout);                                     \
1555     fprintf(stderr, "delay#: unthreaded build.\n");     \
1556     EXIT(EXIT_FAILURE);                                 \
1557   }
1558
1559 #endif
1560
1561 #ifdef CONCURRENT
1562
1563 /* ToDo: something for GRAN */
1564
1565 #define waitReadZh(liveness, fd)                        \
1566   {                                                     \
1567     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1568       WaitingThreadsHd = CurrentTSO;                    \
1569     else                                                \
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);                            \
1575   }
1576
1577 #else
1578
1579 #define waitReadZh(liveness, fd)                        \
1580   {                                                     \
1581     fflush(stdout);                                     \
1582     fprintf(stderr, "waitRead#: unthreaded build.\n");  \
1583     EXIT(EXIT_FAILURE);                                 \
1584   }
1585
1586 #endif
1587
1588 #ifdef CONCURRENT
1589
1590 /* ToDo: something for GRAN */
1591
1592 #ifdef HAVE_SYS_TYPES_H
1593 #include <sys/types.h>
1594 #endif  HAVE_SYS_TYPES_H */
1595
1596 #define waitWriteZh(liveness, fd)                       \
1597   {                                                     \
1598     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1599       WaitingThreadsHd = CurrentTSO;                    \
1600     else                                                \
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);                            \
1606   }
1607
1608 #else
1609
1610 #define waitWriteZh(liveness, fd)                       \
1611   {                                                     \
1612     fflush(stdout);                                     \
1613     fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1614     EXIT(EXIT_FAILURE);                                 \
1615   }
1616
1617 #endif
1618
1619 \end{code}
1620
1621 %************************************************************************
1622 %*                                                                      *
1623 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1624 %*                                                                      *
1625 %************************************************************************
1626
1627 \begin{code}
1628 extern P_ TopClosure;
1629 EXTFUN(ErrorIO_innards);
1630 EXTFUN(__std_entry_error__);
1631
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); \
1637     } while(0)
1638
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)))
1643 #else
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)))
1647 #endif
1648
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);)
1658
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)
1664 #else
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)
1669 #endif
1670
1671 #define STG_SIG_DFL     (-1)
1672 #define STG_SIG_IGN     (-2)
1673 #define STG_SIG_ERR     (-3)
1674
1675 StgInt getErrorHandler(STG_NO_ARGS);
1676 #ifndef PAR
1677 void   raiseError PROTO((StgStablePtr handler));
1678 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1679 #endif
1680 void decrementErrorCount(STG_NO_ARGS);
1681
1682 #define stg_catchError(sp)        SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1683 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1684 \end{code}
1685
1686 %************************************************************************
1687 %*                                                                      *
1688 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1689 %*                                                                      *
1690 %************************************************************************
1691
1692
1693 The type of these should be:
1694
1695 \begin{verbatim}
1696 makeStablePointer#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1697 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1698 \end{verbatim}
1699
1700 Since world-tokens are no longer explicitly passed around, the
1701 implementations have a few less arguments/results.
1702
1703 The simpler one is @deRefStablePointer#@ (which is only a primop
1704 because it is more polymorphic than is allowed of a ccall).
1705
1706 \begin{code}
1707 #ifdef PAR
1708
1709 #define deRefStablePtrZh(ri,sp)                                     \
1710 do {                                                                \
1711     fflush(stdout);                                                 \
1712     fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1713     EXIT(EXIT_FAILURE);                                             \
1714 } while(0)
1715
1716 #else /* !PAR */
1717
1718 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1719
1720 #define deRefStablePtrZh(ri,sp) \
1721    ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1722 \end{code}
1723
1724 Declarations for other stable pointer operations.
1725
1726 \begin{code}
1727 void    freeStablePointer       PROTO((I_ stablePtr));
1728
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);)
1738
1739 EXTFUN(stopPerformIODirectReturn);
1740 EXTFUN(startPerformIO);
1741 EXTFUN(stopEnterIntDirectReturn);
1742 EXTFUN(startEnterInt);
1743 EXTFUN(stopEnterFloatDirectReturn);
1744 EXTFUN(startEnterFloat);
1745
1746 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1747
1748 #endif /* !PAR */
1749
1750 IF_RTS(extern I_ ErrorIO_call_count;)
1751 \end{code}
1752
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!
1757
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@.
1761
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...)
1767
1768 \begin{code}
1769 #ifndef PAR
1770
1771 /* Calculate SP Table size from number of pointers */
1772 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1773
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)
1777
1778 void enlargeSPTable PROTO((P_, P_));
1779
1780 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1781 do {                                                                \
1782   EXTDATA_RO(StablePointerTable_info);                              \
1783   EXTDATA(UnusedSP);                                                \
1784   StgStablePtr newSP;                                               \
1785                                                                     \
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);                          \
1792     }                                                               \
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);                       \
1798                                                                     \
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;                  \
1803     }                                                               \
1804   }                                                                 \
1805                                                                     \
1806   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);               \
1807   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1808   CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable );           \
1809   stablePtr = newSP;                                                \
1810 } while (0)
1811
1812 #else
1813
1814 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1815 do {                                                                \
1816     fflush(stdout);                                                 \
1817     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1818     EXIT(EXIT_FAILURE);                                             \
1819 } while(0)
1820
1821 #endif /* !PAR */
1822 \end{code}
1823
1824 %************************************************************************
1825 %*                                                                      *
1826 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1827 %*                                                                      *
1828 %************************************************************************
1829
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
1832 the result into.
1833
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]
1837
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.
1843
1844 ToDo ADR: The degree of non-determinism could be greatly reduced by
1845 following indirections.
1846
1847 \begin{code}
1848 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1849 \end{code}
1850
1851 %************************************************************************
1852 %*                                                                      *
1853 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1854 %*                                                                      *
1855 %************************************************************************
1856
1857 Assuming local sparking in some form, we can now inline the spark request.
1858
1859 We build a doubly-linked list in the heap, so that we can handle FIFO
1860 or LIFO scheduling as we please.
1861
1862 Anything with tag >= 0 is in WHNF, so we discard it.
1863
1864 \begin{code}
1865 #ifdef CONCURRENT
1866
1867 ED_(Prelude_Z91Z93_closure);
1868 ED_(True_closure);
1869
1870 #if defined(GRAN)
1871 #define parZh(r,node)                           \
1872         PARZh(r,node,1,0,0,0,0,0)
1873
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)
1876
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)
1879
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)
1882
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)
1885
1886 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local)        \
1887 {                                                       \
1888   sparkq result;                                                \
1889   if (SHOULD_SPARK(node)) {                             \
1890     SaveAllStgRegs();                                   \
1891     { sparkq result;                                            \
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);   \
1897       } else {       \
1898         GranSimSparkAt(result,where,identifier);        \
1899       }        \
1900       context_switch = 1;                               \
1901     }                                                   \
1902     RestoreAllStgRegs();                                \
1903   } else if (do_qp_prof) {                              \
1904     I_ tid = threadId++;                                \
1905     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1906   }                                                     \
1907   r = 1; /* return code for successful spark -- HWL */  \
1908 }
1909
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)
1912
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)
1915
1916 #if 1
1917
1918 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1919 {                                                       \
1920   if (SHOULD_SPARK(node)) {                             \
1921     SaveAllStgRegs();                                   \
1922     { sparkq result;                                            \
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;                               \
1927     }                                                   \
1928     RestoreAllStgRegs();                                \
1929   } else if (do_qp_prof) {                              \
1930     I_ tid = threadId++;                                \
1931     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1932   }                                                     \
1933   r = 1; /* return code for successful spark -- HWL */  \
1934 }
1935
1936 #else
1937
1938 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1939 {                                                       \
1940   sparkq result;                                                \
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);     \
1949   }                                                     \
1950   r = 1; /* return code for successful spark -- HWL */  \
1951 }
1952
1953 #endif
1954
1955 #define copyableZh(r,node)                              \
1956   /* copyable not yet implemented!! */
1957
1958 #define noFollowZh(r,node)                              \
1959   /* noFollow not yet implemented!! */
1960
1961 #else  /* !GRAN */
1962
1963 extern I_ required_thread_count;
1964
1965 #ifdef PAR
1966 #define COUNT_SPARK     TSO_GLOBALSPARKS(CurrentTSO)++
1967 #else
1968 #define COUNT_SPARK
1969 #endif
1970
1971 /*
1972    Note that we must bump the required thread count NOW, rather
1973    than when the thread is actually created.
1974  */
1975
1976 #define forkZh(r,liveness,node)                         \
1977 {                                                       \
1978   while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
1979     DO_YIELD((liveness << 1) | 1);                      \
1980   COUNT_SPARK;                                          \
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);     \
1986   }                                                     \
1987   required_thread_count++;                              \
1988   context_switch = 1;                                   \
1989   r = 1; /* Should not be necessary */                  \
1990 }
1991
1992 #define parZh(r,node)                                   \
1993 {                                                       \
1994   COUNT_SPARK;                                          \
1995   if (SHOULD_SPARK(node) &&                             \
1996    PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) {  \
1997     *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node);     \
1998   } else {                                              \
1999     sparksIgnored++;                                    \
2000     if (DO_QP_PROF) {                                   \
2001       I_ tid = threadId++;                              \
2002       SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);   \
2003     }                                                   \
2004   }                                                     \
2005   r = 1; /* Should not be necessary */                  \
2006 }
2007
2008 #endif  /* GRAN */
2009 \end{code}
2010
2011 The following seq# code should only be used in unoptimized code.
2012 Be warned: it's a potential bug-farm.
2013
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.
2022
2023 \begin{code}
2024
2025 ED_RO_(vtbl_seq);
2026
2027 #define seqZh(r,liveness,node)              \
2028   ({                                        \
2029     __label__ cont;                         \
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;         \
2035     Node = node;                            \
2036     ENT_VIA_NODE();                         \
2037     InfoPtr = (D_)(INFO_PTR(Node));         \
2038     JMP_(ENTRY_CODE(InfoPtr));              \
2039     cont:                                   \
2040     r = 1; /* Should be unnecessary */      \
2041   })
2042
2043 #endif  /* CONCURRENT */
2044 \end{code}
2045
2046 %************************************************************************
2047 %*                                                                      *
2048 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2049 %*                                                                      *
2050 %************************************************************************
2051
2052 [Based on previous MallocPtr comments -- SOF]
2053
2054 This macro is used to construct a ForeignObj on the heap.
2055
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.
2060
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
2064
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.
2069 WDP 95/1)
2070
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)
2073
2074 \begin{code}
2075 #ifndef PAR
2076
2077 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2078
2079 #define makeForeignObjZh(r, liveness, mptr, finalise)    \
2080 do {                                                     \
2081   P_ result;                                             \
2082                                                          \
2083   HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0);              \
2084   CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */   \
2085                                                                    \
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;                          \
2092                                                         \
2093 /*                                                      \
2094   printf("DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n",        \
2095       result,                                           \
2096       result[0],result[1],                              \
2097       result[2],result[3]);                             \
2098 */                                                      \
2099   CHECK_ForeignObj_CLOSURE( result );                   \
2100   VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2101                                                         \
2102   (r) = (P_) result;                                    \
2103 } while (0)
2104
2105 #else
2106 #define makeForeignObjZh(r, liveness, mptr, finalise)               \
2107 do {                                                                \
2108     fflush(stdout);                                                 \
2109     fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2110     EXIT(EXIT_FAILURE);                                             \
2111 } while(0)
2112
2113 #endif /* !PAR */
2114 \end{code}
2115
2116
2117 End-of-file's multi-slurp protection:
2118 \begin{code}
2119 #endif /* ! STGMACROS_H */
2120 \end{code}