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 extern 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 extern 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-arity-chks]{Arity checks (for debugging)}
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 This is a debugging feature.  Each call to fast-entry-point code sets
 248 @ExpectedArity@ to some value, and the callee then checks that the
 249 value is as expected.
 250
 251 \begin{code}
 252 #if defined(__DO_ARITY_CHKS__)
 253
 254 extern I_                        ExpectedArity;
 255 extern void ArityError PROTO((I_)) STG_NORETURN;
 256
 257 #define SET_ARITY(n) do { ExpectedArity = (n); } while(0)
 258 #define CHK_ARITY(n)                    \
 259         do {                            \
 260         if (ExpectedArity != (n)) {     \
 261             ULTRASAFESTGCALL1(void,(void *, I_),ArityError,n);  \
 262         }}while(0)
 263
 264 #else /* ! __DO_ARITY_CHKS__: normal case */
 265
 266 #define SET_ARITY(n) /* nothing */
 267 #define CHK_ARITY(n) /* nothing */
 268
 269 #endif /* ! __DO_ARITY_CHKS__ */
 270 \end{code}
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsubsection[StgMacros-heap-chks]{Heap-overflow checks}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 Please see the general discussion/commentary about ``what really
 279 happens in a GC,'' in \tr{SMinterface.lh}.
 280
 281 \begin{code}
 282 extern void PerformGC PROTO((W_));
 283 void RealPerformGC PROTO((W_ liveness, W_ reqsize, W_  always_reenter_node, rtsBool do_full_collection));
 284 void checkInCCallGC(STG_NO_ARGS);
 285
 286 #ifndef PAR
 287 void StgPerformGarbageCollection(STG_NO_ARGS);
 288 #endif
 289
 290 #ifndef CONCURRENT
 291
 292 #define OR_MSG_PENDING  /* never */
 293
 294 #define HEAP_OVERFLOW(liveness,n,reenter)       \
 295     do {                                        \
 296     DO_GC((((W_)n)<<8)|(liveness));             \
 297     } while (0)
 298
 299 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
 300 #define HEAP_OVERFLOW_REQSIZE(args)     (((args) >> 8) & REQSIZE_BITMASK)
 301 #define HEAP_OVERFLOW_REENTER(args)     0
 302 #define HEAP_OVERFLOW_LIVENESS(args)    ((args) & 0xff)
 303
 304 #else /* CONCURRENT */
 305
 306 extern void ReallyPerformThreadGC PROTO((W_, rtsBool));
 307
 308 #define HEAP_OVERFLOW(liveness,n,reenter)       \
 309     do {                                        \
 310     DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
 311     } while (0)
 312
 313 #define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
 314 #define HEAP_OVERFLOW_REQSIZE(args)     (((args) >> 9) & REQSIZE_BITMASK)
 315 #define HEAP_OVERFLOW_REENTER(args)     (((args) >> 8) & 0x1)
 316 #define HEAP_OVERFLOW_LIVENESS(args)    ((args) & 0xff)
 317
 318 #ifndef PAR
 319
 320 #define OR_MSG_PENDING  /* never */
 321
 322 #else
 323
 324 extern int PacketsWaiting;              /*Probes for incoming messages*/
 325 extern int heapChkCounter;              /*Not currently used! We check for messages when*/
 326                                         /*a thread is resheduled PWT*/
 327 /* #define OR_MSG_PENDING       || (--heapChkCounter == 0 && PacketsWaiting())*/
 328 #define OR_MSG_PENDING  /* never */
 329
 330 #endif  /* PAR */
 331 #endif  /* CONCURRENT */
 332
 333 #if 0 /* alpha_TARGET_ARCH */
 334 #define CACHE_LINE  4   /* words */
 335 #define LINES_AHEAD 3
 336 #define PRE_FETCH(n)                                    \
 337 do {                                                    \
 338  StgInt j;                                              \
 339  j = ((STG_VOLATILE StgInt *) Hp)[LINES_AHEAD * CACHE_LINE];    \
 340 } while(0);
 341 #define EXTRA_HEAP_WORDS (CACHE_LINE * LINES_AHEAD)
 342 #else
 343 #define PRE_FETCH(reg)
 344 #define EXTRA_HEAP_WORDS 0
 345 #endif
 346
 347 #if defined(GRAN)
 348 #define HEAP_CHK(liveness_mask,n,reenter)                       \
 349         do {                                                    \
 350         /* TICKY_PARANOIA(__FILE__, __LINE__); */               \
 351         /* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */             \
 352         ALLOC_HEAP(n); /* ticky profiling */                    \
 353         GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
 354         if (((Hp = Hp + (n)) > HpLim)) {                        \
 355             /* Old:  STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
 356             HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
 357         }}while(0)
 358
 359 #else
 360
 361 #define HEAP_CHK(liveness_mask,n,reenter)               \
 362 do {                                                    \
 363   /* TICKY_PARANOIA(__FILE__, __LINE__); */             \
 364   PRE_FETCH(n);                                         \
 365   ALLOC_HEAP(n); /* ticky profiling */                  \
 366   if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
 367     HEAP_OVERFLOW(liveness_mask,n,reenter);             \
 368   }                                                     \
 369 } while(0)
 370
 371 #endif  /* GRAN */
 372
 373 #ifdef CONCURRENT
 374
 375 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter) \
 376 do {                                                    \
 377   /* TICKY_PARANOIA(__FILE__, __LINE__); */             \
 378   PRE_FETCH(n);                                         \
 379   ALLOC_HEAP(n); /* ticky profiling */                  \
 380   if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
 381     HEAP_OVERFLOW(liveness_mask,n,reenter);             \
 382     n = TSO_ARG1(CurrentTSO);                           \
 383   }} while(0)
 384
 385 #else
 386
 387 #define HEAP_CHK_AND_RESTORE_N(liveness_mask,n,reenter)     \
 388     HEAP_CHK(liveness_mask,n,reenter)
 389
 390 #endif
 391
 392 \end{code}
 393
 394
 395 %************************************************************************
 396 %*                                                                      *
 397 \subsection[StgMacros-prim-ops]{Primitive operations}
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 One thing to be {\em very careful about} with these macros that assign
 402 to results is that the assignment must come {\em last}.  Some of the
 403 other arguments may be in terms of addressing modes that get clobbered
 404 by the assignment.  (Dirty imperative programming RULES!)
 405
 406 The order here is roughly that in \tr{compiler/prelude/PrimOps.lhs}.
 407
 408 %************************************************************************
 409 %*                                                                      *
 410 \subsubsection[StgMacros-compare-primops]{Primitive comparison ops on basic types}
 411 %*                                                                      *
 412 %************************************************************************
 413
 414 We cast the chars in case one of them is a literal (so C things work right
 415 even for 8-bit chars).
 416 \begin{code}
 417 #define gtCharZh(r,a,b) r=(I_)((a)> (b))
 418 #define geCharZh(r,a,b) r=(I_)((a)>=(b))
 419 #define eqCharZh(r,a,b) r=(I_)((a)==(b))
 420 #define neCharZh(r,a,b) r=(I_)((a)!=(b))
 421 #define ltCharZh(r,a,b) r=(I_)((a)< (b))
 422 #define leCharZh(r,a,b) r=(I_)((a)<=(b))
 423
 424 #define gtIntZh(r,a,b)  r=(I_)((a) >(b))
 425 #define geIntZh(r,a,b)  r=(I_)((a)>=(b))
 426 #define eqIntZh(r,a,b)  r=(I_)((a)==(b))
 427 #define neIntZh(r,a,b)  r=(I_)((a)!=(b))
 428 #define ltIntZh(r,a,b)  r=(I_)((a) <(b))
 429 #define leIntZh(r,a,b)  r=(I_)((a)<=(b))
 430
 431 #define gtWordZh(r,a,b) r=(I_)((a) >(b))
 432 #define geWordZh(r,a,b) r=(I_)((a)>=(b))
 433 #define eqWordZh(r,a,b) r=(I_)((a)==(b))
 434 #define neWordZh(r,a,b) r=(I_)((a)!=(b))
 435 #define ltWordZh(r,a,b) r=(I_)((a) <(b))
 436 #define leWordZh(r,a,b) r=(I_)((a)<=(b))
 437
 438 #define gtAddrZh(r,a,b) r=(I_)((a) >(b))
 439 #define geAddrZh(r,a,b) r=(I_)((a)>=(b))
 440 #define eqAddrZh(r,a,b) r=(I_)((a)==(b))
 441 #define neAddrZh(r,a,b) r=(I_)((a)!=(b))
 442 #define ltAddrZh(r,a,b) r=(I_)((a) <(b))
 443 #define leAddrZh(r,a,b) r=(I_)((a)<=(b))
 444
 445 #define gtFloatZh(r,a,b)  r=(I_)((a)> (b))
 446 #define geFloatZh(r,a,b)  r=(I_)((a)>=(b))
 447 #define eqFloatZh(r,a,b)  r=(I_)((a)==(b))
 448 #define neFloatZh(r,a,b)  r=(I_)((a)!=(b))
 449 #define ltFloatZh(r,a,b)  r=(I_)((a)< (b))
 450 #define leFloatZh(r,a,b)  r=(I_)((a)<=(b))
 451
 452 #define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
 453 #define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
 454 #define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
 455 #define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
 456 #define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
 457 #define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
 458 \end{code}
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsubsection[StgMacros-char-primops]{Primitive @Char#@ ops (and @LitString#@ish things, too)}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 We cast the chars in case one of them is a literal (so C things work right
 467 even for 8-bit chars).
 468 \begin{code}
 469 #define ordZh(r,a)      r=(I_)((W_) (a))
 470 #define chrZh(r,a)      r=(StgChar)((W_)(a))
 471 \end{code}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsubsection[StgMacros-int-primops]{Primitive @Int#@ ops}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 I_ stg_div PROTO((I_ a, I_ b));
 481
 482 #define plusIntZh(r,a,b)        r=(a)+(b)
 483 #define minusIntZh(r,a,b)       r=(a)-(b)
 484 #define timesIntZh(r,a,b)       r=(a)*(b)
 485 #define quotIntZh(r,a,b)        r=(a)/(b)
 486 #define divIntZh(r,a,b)         r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
 487 #define remIntZh(r,a,b)         r=(a)%(b)
 488 #define negateIntZh(r,a)        r=-(a)
 489 \end{code}
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsubsection[StgMacros-word-primops]{Primitive @Word#@ ops}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 #define andZh(r,a,b)    r=(a)&(b)
 499 #define orZh(r,a,b)     r=(a)|(b)
 500 #define notZh(r,a)      r=~(a)
 501
 502 #define shiftLZh(r,a,b)   r=(a)<<(b)
 503 #define shiftRAZh(r,a,b)  r=(a)>>(b)
 504 #define shiftRLZh(r,a,b)  r=(a)>>(b)
 505 #define iShiftLZh(r,a,b)  r=(a)<<(b)
 506 #define iShiftRAZh(r,a,b) r=(a)>>(b)
 507 #define iShiftRLZh(r,a,b) r=(a)>>(b)
 508
 509 #define int2WordZh(r,a) r=(W_)(a)
 510 #define word2IntZh(r,a) r=(I_)(a)
 511 \end{code}
 512
 513 %************************************************************************
 514 %*                                                                      *
 515 \subsubsection[StgMacros-addr-primops]{Primitive @Addr#@ ops}
 516 %*                                                                      *
 517 %************************************************************************
 518
 519 \begin{code}
 520 #define int2AddrZh(r,a) r=(A_)(a)
 521 #define addr2IntZh(r,a) r=(I_)(a)
 522 \end{code}
 523
 524 %************************************************************************
 525 %*                                                                      *
 526 \subsubsection[StgMacros-float-primops]{Primitive @Float#@ ops}
 527 %*                                                                      *
 528 %************************************************************************
 529
 530 \begin{code}
 531 #define plusFloatZh(r,a,b)      r=(a)+(b)
 532 #define minusFloatZh(r,a,b)     r=(a)-(b)
 533 #define timesFloatZh(r,a,b)     r=(a)*(b)
 534 #define divideFloatZh(r,a,b)    r=(a)/(b)
 535 #define negateFloatZh(r,a)      r=-(a)
 536
 537 #define int2FloatZh(r,a)        r=(StgFloat)(a)
 538 #define float2IntZh(r,a)        r=(I_)(a)
 539
 540 #define expFloatZh(r,a)         r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
 541 #define logFloatZh(r,a)         r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
 542 #define sqrtFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
 543 #define sinFloatZh(r,a)         r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
 544 #define cosFloatZh(r,a)         r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
 545 #define tanFloatZh(r,a)         r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
 546 #define asinFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
 547 #define acosFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
 548 #define atanFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
 549 #define sinhFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
 550 #define coshFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
 551 #define tanhFloatZh(r,a)        r=(StgFloat) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
 552 #define powerFloatZh(r,a,b)     r=(StgFloat) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
 553
 554 /* encoding/decoding given w/ Integer stuff */
 555 \end{code}
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsubsection[StgMacros-double-primops]{Primitive @Double#@ ops}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 \begin{code}
 564 #define plusDoubleZh(r,a,b)     r=(a)+(b)
 565 #define minusDoubleZh(r,a,b)    r=(a)-(b)
 566 #define timesDoubleZh(r,a,b)    r=(a)*(b)
 567 #define divideDoubleZh(r,a,b)   r=(a)/(b)
 568 #define negateDoubleZh(r,a)     r=-(a)
 569
 570 #define int2DoubleZh(r,a)       r=(StgDouble)(a)
 571 #define double2IntZh(r,a)       r=(I_)(a)
 572
 573 #define float2DoubleZh(r,a)     r=(StgDouble)(a)
 574 #define double2FloatZh(r,a)     r=(StgFloat)(a)
 575
 576 #define expDoubleZh(r,a)        r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),exp,a)
 577 #define logDoubleZh(r,a)        r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),log,a)
 578 #define sqrtDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sqrt,a)
 579 #define sinDoubleZh(r,a)        r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sin,a)
 580 #define cosDoubleZh(r,a)        r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cos,a)
 581 #define tanDoubleZh(r,a)        r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tan,a)
 582 #define asinDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),asin,a)
 583 #define acosDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),acos,a)
 584 #define atanDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),atan,a)
 585 #define sinhDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
 586 #define coshDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
 587 #define tanhDoubleZh(r,a)       r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
 588 #define powerDoubleZh(r,a,b)    r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
 589 \end{code}
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsubsection[StgMacros-integer-primops]{Primitive @Integer@-related ops (GMP stuff)}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 Dirty macros we use for the real business.
 598
 599 INVARIANT: When one of these macros is called, the only live data is
 600 tidily on the STG stacks or in the STG registers (the code generator
 601 ensures this).  If there are any pointer-arguments, they will be in
 602 the first \tr{Ret*} registers (e.g., \tr{da} arg of \tr{gmpTake1Return1}).
 603
 604 OK, here are the real macros:
 605 \begin{code}
 606 #define gmpTake1Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, aa,sa,da)   \
 607 { MP_INT arg;                                                                   \
 608   MP_INT result;                                                                \
 609   I_ space = size_chk_macro(sa);                                                \
 610                                                                                 \
 611   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 612   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 613                                                                                 \
 614   /* Now we can initialise (post possible GC) */                                \
 615   arg.alloc     = (aa);                                                         \
 616   arg.size      = (sa);                                                         \
 617   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da));                     \
 618                                                                                 \
 619   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result);                       \
 620                                                                                 \
 621   /* Perform the operation */                                                   \
 622   SAFESTGCALL2(void,(void *, MP_INT *, MP_INT *),mpz_op,&result,&arg);          \
 623                                                                                 \
 624   GMP_HEAP_HANDBACK();          /* restore Hp */                                \
 625   (ar) = result.alloc;                                                          \
 626   (sr) = result.size;                                                           \
 627   (dr) = (B_) (result.d - DATA_HS);                                             \
 628   /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
 629 }
 630
 631
 632 #define gmpTake2Return1(size_chk_macro, liveness, mpz_op, ar,sr,dr, a1,s1,d1, a2,s2,d2)\
 633 { MP_INT arg1;                                                                  \
 634   MP_INT arg2;                                                                  \
 635   MP_INT result;                                                                \
 636   I_ space = size_chk_macro(s1,s2);                                             \
 637                                                                                 \
 638   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 639   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 640                                                                                 \
 641   /* Now we can initialise (post possible GC) */                                \
 642   arg1.alloc    = (a1);                                                         \
 643   arg1.size     = (s1);                                                         \
 644   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 645   arg2.alloc    = (a2);                                                         \
 646   arg2.size     = (s2);                                                         \
 647   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 648                                                                                 \
 649   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result);                       \
 650                                                                                 \
 651   /* Perform the operation */                                                   \
 652   SAFESTGCALL3(void,(void *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result,&arg1,&arg2); \
 653                                                                                 \
 654   GMP_HEAP_HANDBACK();          /* restore Hp */                                \
 655   (ar) = result.alloc;                                                          \
 656   (sr) = result.size;                                                           \
 657   (dr) = (B_) (result.d - DATA_HS);                                             \
 658   /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
 659 }
 660
 661 #define gmpTake2Return2(size_chk_macro, liveness, mpz_op, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2) \
 662 { MP_INT arg1;                                                                  \
 663   MP_INT arg2;                                                                  \
 664   MP_INT result1;                                                               \
 665   MP_INT result2;                                                               \
 666   I_ space = size_chk_macro(s1,s2);                                             \
 667                                                                                 \
 668   /* Check that there will be enough heap & make Hp visible to GMP allocator */ \
 669   GMP_HEAP_LOOKAHEAD(liveness,space);                                           \
 670                                                                                 \
 671   /* Now we can initialise (post possible GC) */                                \
 672   arg1.alloc    = (a1);                                                         \
 673   arg1.size     = (s1);                                                         \
 674   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 675   arg2.alloc    = (a2);                                                         \
 676   arg2.size     = (s2);                                                         \
 677   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 678                                                                                 \
 679   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result1);                      \
 680   SAFESTGCALL1(void,(void *, MP_INT *),mpz_init,&result2);                      \
 681                                                                                 \
 682   /* Perform the operation */                                                   \
 683   SAFESTGCALL4(void,(void *, MP_INT *, MP_INT *, MP_INT *, MP_INT *),mpz_op,&result1,&result2,&arg1,&arg2); \
 684                                                                                 \
 685   GMP_HEAP_HANDBACK();          /* restore Hp */                                \
 686   (ar1) = result1.alloc;                                                        \
 687   (sr1) = result1.size;                                                         \
 688   (dr1) = (B_) (result1.d - DATA_HS);                                           \
 689   (ar2) = result2.alloc;                                                        \
 690   (sr2) = result2.size;                                                         \
 691   (dr2) = (B_) (result2.d - DATA_HS);                                           \
 692 }
 693 \end{code}
 694
 695 Some handy size-munging macros: sometimes gratuitously {\em conservative}.
 696 The \tr{+16} is to allow for the initial allocation of \tr{MP_INT} results.
 697 The \tr{__abs} stuff is because negative-ness of GMP things is encoded
 698 in their ``size''...
 699 \begin{code}
 700 #define __abs(a)                (( (a) >= 0 ) ? (a) : (-(a)))
 701 #define GMP_SIZE_ONE()          (2 + DATA_HS + 16)
 702 #define GMP_SAME_SIZE(a)        (__abs(a) + DATA_HS + 16)
 703 #define GMP_MAX_SIZE(a,b)       ((__abs(a) > __abs(b) ? __abs(a) : __abs(b)) + 1 + DATA_HS + 16)
 704                                 /* NB: the +1 is for the carry (or whatever) */
 705 #define GMP_2MAX_SIZE(a,b)      (2 * GMP_MAX_SIZE(a,b))
 706 #define GMP_ADD_SIZES(a,b)      (__abs(a) + __abs(b) + 1 + DATA_HS + 16)
 707                                 /* the +1 may just be paranoia */
 708 \end{code}
 709
 710 For the Integer/GMP stuff, we have macros that {\em look ahead} for
 711 some space, but don't actually grab it.
 712
 713 If there are live pointers at the time of the lookahead, the caller
 714 must make sure they are in \tr{Ret1}, \tr{Ret2}, ..., so they can be
 715 handled normally.  We achieve this by having the code generator {\em
 716 always} pass args to may-invoke-GC primitives in registers, using the
 717 normal pointers-first policy.  This means that, if we do go to garbage
 718 collection, everything is already in the Right Place.
 719
 720 Saving and restoring Hp register so the MP allocator can see them. If we are
 721 performing liftime profiling need to save and restore HpLim as well so that
 722 it can be bumped if allocation occurs.
 723
 724 The second argument to @GMP_HEAP_LOOKAHEAD@ must be an lvalue so that
 725 it can be restored from @TSO_ARG1@ after a failed @HEAP_CHK@ in
 726 threaded land.
 727
 728 \begin{code}
 729 #define GMP_HEAP_LOOKAHEAD(liveness,n)                  \
 730         do {                                            \
 731         HEAP_CHK_AND_RESTORE_N(liveness,n,0);           \
 732         Hp = Hp - (n);                                  \
 733         UN_ALLOC_HEAP(n);       /* Undo ticky-ticky */  \
 734         SAVE_Hp = Hp;           /* Hand over the hp */  \
 735         DEBUG_SetGMPAllocBudget(n)                      \
 736         }while(0)
 737
 738 #define GMP_HEAP_HANDBACK()                             \
 739         Hp = SAVE_Hp;                                   \
 740         DEBUG_ResetGMPAllocBudget()
 741 \end{code}
 742
 743 \begin{code}
 744 void *stgAllocForGMP   PROTO((size_t size_in_bytes));
 745 void *stgReallocForGMP PROTO((void *ptr, size_t old_size, size_t new_size));
 746 void stgDeallocForGMP  PROTO((void *ptr, size_t size));
 747
 748 #ifdef ALLOC_DEBUG
 749 extern StgInt DEBUG_GMPAllocBudget;
 750 #define DEBUG_SetGMPAllocBudget(n)  DEBUG_GMPAllocBudget = (n);
 751 #define DEBUG_ResetGMPAllocBudget() DEBUG_GMPAllocBudget = 0;
 752 #else
 753 #define DEBUG_SetGMPAllocBudget(n)  /*nothing*/
 754 #define DEBUG_ResetGMPAllocBudget() /*nothing*/
 755 #endif
 756 \end{code}
 757
 758 The real business (defining Integer primops):
 759 \begin{code}
 760 #define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
 761         gmpTake1Return1(GMP_SAME_SIZE, liveness, mpz_neg, ar,sr,dr, aa,sa,da)
 762
 763 #define plusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
 764         gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_add, ar,sr,dr, a1,s1,d1, a2,s2,d2)
 765 #define minusIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
 766         gmpTake2Return1(GMP_MAX_SIZE, liveness, mpz_sub, ar,sr,dr, a1,s1,d1, a2,s2,d2)
 767 #define timesIntegerZh(ar,sr,dr, liveness, a1,s1,d1, a2,s2,d2) \
 768         gmpTake2Return1(GMP_ADD_SIZES, liveness, mpz_mul, ar,sr,dr, a1,s1,d1, a2,s2,d2)
 769
 770 /* div, mod, quot, rem are defined w/ quotRem & divMod */
 771
 772 #define quotRemIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness, a1,s1,d1, a2,s2,d2) \
 773         gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_divmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
 774 #define divModIntegerZh(ar1,sr1,dr1, ar2,sr2,dr2, liveness,  a1,s1,d1, a2,s2,d2) \
 775         gmpTake2Return2(GMP_2MAX_SIZE, liveness, mpz_mdivmod, ar1,sr1,dr1, ar2,sr2,dr2, a1,s1,d1, a2,s2,d2)
 776 \end{code}
 777
 778 Comparison ops (@<@, @>=@, etc.) are defined in terms of the cmp
 779 fellow (returns -ve, 0, or +ve).
 780 \begin{code}
 781 #define cmpIntegerZh(r, hp, a1,s1,d1, a2,s2,d2) /* calls mpz_cmp */             \
 782 { MP_INT arg1;                                                                  \
 783   MP_INT arg2;                                                                  \
 784   /* Does not allocate memory */                                                \
 785                                                                                 \
 786   arg1.alloc    = (a1);                                                         \
 787   arg1.size     = (s1);                                                         \
 788   arg1.d        = (unsigned long int *) (BYTE_ARR_CTS(d1));                     \
 789   arg2.alloc    = (a2);                                                         \
 790   arg2.size     = (s2);                                                         \
 791   arg2.d        = (unsigned long int *) (BYTE_ARR_CTS(d2));                     \
 792                                                                                 \
 793   (r) = SAFESTGCALL2(I_,(void *, MP_INT *, MP_INT *),mpz_cmp,&arg1,&arg2);      \
 794 }
 795 \end{code}
 796
 797 Coercions:
 798
 799 \begin{code}
 800 #define integer2IntZh(r, hp, aa,sa,da)                                          \
 801 { MP_INT arg;                                                                   \
 802   /* Does not allocate memory */                                                \
 803                                                                                 \
 804   arg.alloc     = (aa);                                                         \
 805   arg.size      = (sa);                                                         \
 806   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da));                     \
 807                                                                                 \
 808   (r) = SAFESTGCALL1(I_,(void *, MP_INT *),mpz_get_si,&arg);                    \
 809 }
 810
 811 /* Since we're forced to know a little bit about MP_INT layout to do this with
 812    pre-allocated heap, we just inline the whole of mpz_init_set_si here.
 813         ** DIRE WARNING.  if mpz_init_set_si changes, so does this! ***
 814 */
 815
 816 #define int2IntegerZh(ar,sr,dr, hp, i)                                          \
 817 { StgInt val; /* to snaffle arg to avoid aliasing */                            \
 818                                                                                 \
 819   val = (i);  /* snaffle... */                                                  \
 820                                                                                 \
 821   SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);           \
 822                                                                                 \
 823   if      ((val) < 0) { (sr) = -1; (hp)[DATA_HS] = -(val); }                    \
 824   else if ((val) > 0) { (sr) =  1; (hp)[DATA_HS] =  (val); }                    \
 825   else /* val==0 */   { (sr) =  0; }                                            \
 826   (ar) = 1;                                                                     \
 827   (dr) = (B_)(hp);              /* dr is an StgByteArray */                     \
 828 }
 829
 830 #define word2IntegerZh(ar,sr,dr, hp, i)                                         \
 831 { StgWord val; /* to snaffle arg to avoid aliasing */                           \
 832                                                                                 \
 833   val = (i);  /* snaffle... */                                                  \
 834                                                                                 \
 835   SET_DATA_HDR((hp),ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);           \
 836                                                                                 \
 837   if ((val) != 0)     { (sr) =  1; (hp)[DATA_HS] =  (val); }                    \
 838   else /* val==0 */   { (sr) =  0; }                                            \
 839   (ar) = 1;                                                                     \
 840   (dr) = (B_)(hp);              /* dr is an StgByteArray */                     \
 841 }
 842
 843 \end{code}
 844
 845 Then there are a few oddments to make life easier:
 846 \begin{code}
 847 /*
 848    DIRE WARNING.
 849    The "str" argument must be a literal C string.
 850
 851         addr2Integer( ..., "foo")   OK!
 852
 853         x = "foo";
 854         addr2Integer( ..., x)       NO! NO!
 855 */
 856
 857 #define addr2IntegerZh(ar,sr,dr, liveness, str)                                 \
 858 { MP_INT result;                                                                \
 859   /* taking the number of bytes/8 as the number of words of lookahead           \
 860      is plenty conservative */                                                  \
 861   I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1);                                \
 862                                                                                 \
 863   GMP_HEAP_LOOKAHEAD(liveness, space);                                          \
 864                                                                                 \
 865   /* Perform the operation */                                                   \
 866   if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
 867       abort();                                                                  \
 868                                                                                 \
 869   GMP_HEAP_HANDBACK();          /* restore Hp */                                \
 870   (ar) = result.alloc;                                                          \
 871   (sr) = result.size;                                                           \
 872   (dr) = (B_) (result.d - DATA_HS);                                             \
 873   /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
 874 }
 875 \end{code}
 876
 877 Encoding and decoding float-ish things is pretty Integer-ish.  We use
 878 these pretty magical support functions, essentially stolen from Lennart:
 879 \begin{code}
 880 StgFloat  __encodeFloat  PROTO((MP_INT *, I_));
 881 void  __decodeFloat  PROTO((MP_INT * /*result1*/,
 882                                 I_ * /*result2*/,
 883                                 StgFloat));
 884
 885 StgDouble __encodeDouble PROTO((MP_INT *, I_));
 886 void  __decodeDouble PROTO((MP_INT * /*result1*/,
 887                                 I_ * /*result2*/,
 888                                 StgDouble));
 889 \end{code}
 890
 891 Some floating-point format info, made with the \tr{enquire} program
 892 (version~4.3) [comes with gcc].
 893 \begin{code}
 894 /* this should be done by CPU architecture, insofar as possible [WDP] */
 895
 896 #if sparc_TARGET_ARCH   \
 897  || alpha_TARGET_ARCH   \
 898  || hppa1_1_TARGET_ARCH \
 899  || i386_TARGET_ARCH    \
 900  || m68k_TARGET_ARCH    \
 901  || mipsel_TARGET_ARCH  \
 902  || mipseb_TARGET_ARCH  \
 903  || powerpc_TARGET_ARCH
 904
 905 /* yes, it is IEEE floating point */
 906 #include "ieee-flpt.h"
 907
 908 #if alpha_dec_osf1_TARGET       \
 909  || i386_TARGET_ARCH            \
 910  || mipsel_TARGET_ARCH
 911
 912 #undef BIGENDIAN /* little-endian weirdos... */
 913 #else
 914 #define BIGENDIAN 1
 915 #endif
 916
 917 #else /* unknown floating-point format */
 918
 919 ******* ERROR *********** Any ideas about floating-point format?
 920
 921 #endif /* unknown floating-point */
 922 \end{code}
 923
 924 \begin{code}
 925 #if alpha_dec_osf1_TARGET
 926 #define encodeFloatZh(r, hp, aa,sa,da, expon)   encodeDoubleZh(r, hp, aa,sa,da, expon)
 927 #else
 928 #define encodeFloatZh(r, hp, aa,sa,da, expon)   \
 929 { MP_INT arg;                                   \
 930   /* Does not allocate memory */                \
 931                                                 \
 932   arg.alloc     = aa;                           \
 933   arg.size      = sa;                           \
 934   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 935                                                 \
 936   r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon));        \
 937 }
 938 #endif /* ! alpha */
 939
 940 #define encodeDoubleZh(r, hp, aa,sa,da, expon)  \
 941 { MP_INT arg;                                   \
 942   /* Does not allocate memory */                \
 943                                                 \
 944   arg.alloc     = aa;                           \
 945   arg.size      = sa;                           \
 946   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 947                                                 \
 948   r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
 949 }
 950
 951 #if alpha_dec_osf1_TARGET
 952 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)  decodeDoubleZh(exponr, ar,sr,dr, hp, f)
 953 #else
 954 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)                          \
 955 { MP_INT mantissa;                                                      \
 956   I_ exponent;                                                          \
 957   StgFloat arg = (f);                                                   \
 958                                                                         \
 959   /* Be prepared to tell Lennart-coded __decodeFloat    */              \
 960   /* where mantissa.d can be put (it does not care about the rest) */   \
 961   SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);     \
 962   mantissa.d = (hp) + DATA_HS;                                          \
 963                                                                         \
 964   /* Perform the operation */                                           \
 965   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg);          \
 966   exponr= exponent;                                                     \
 967   ar    = mantissa.alloc;                                               \
 968   sr    = mantissa.size;                                                \
 969   dr    = (B_)(hp);                                                     \
 970 }
 971 #endif /* !alpha */
 972
 973 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f)                         \
 974 { MP_INT mantissa;                                                      \
 975   I_ exponent;                                                          \
 976   StgDouble arg = (f);                                                  \
 977                                                                         \
 978   /* Be prepared to tell Lennart-coded __decodeDouble   */              \
 979   /* where mantissa.d can be put (it does not care about the rest) */   \
 980   SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);     \
 981   mantissa.d = (hp) + DATA_HS;                                          \
 982                                                                         \
 983   /* Perform the operation */                                           \
 984   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg);                \
 985   exponr= exponent;                                                     \
 986   ar    = mantissa.alloc;                                               \
 987   sr    = mantissa.size;                                                \
 988   dr    = (B_)(hp);                                                     \
 989 }
 990 \end{code}
 991
 992 %************************************************************************
 993 %*                                                                      *
 994 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
 995 %*                                                                      *
 996 %************************************************************************
 997
 998 With GCC, we use magic non-standard inlining; for other compilers, we
 999 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
1000
1001 (The @OMIT_...@ is only used in compiling some of the RTS, none of
1002 which uses these anyway.)
1003
1004 \begin{code}
1005 #if alpha_TARGET_ARCH   \
1006  || i386_TARGET_ARCH    \
1007  || m68k_TARGET_ARCH
1008
1009 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1010 #define PK_FLT(src) (*(StgFloat *)(src))
1011
1012 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
1013 #define PK_DBL(src) (*(StgDouble *)(src))
1014
1015 #else   /* not m68k || alpha || i[34]86 */
1016
1017 /* Special handling for machines with troublesome alignment constraints */
1018
1019 #define FLOAT_ALIGNMENT_TROUBLES    TRUE
1020
1021 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
1022
1023 void        ASSIGN_DBL PROTO((W_ [], StgDouble));
1024 StgDouble   PK_DBL     PROTO((W_ []));
1025 void        ASSIGN_FLT PROTO((W_ [], StgFloat));
1026 StgFloat    PK_FLT     PROTO((W_ []));
1027
1028 #else /* yes, its __GNUC__ && we really want them */
1029
1030 #if sparc_TARGET_ARCH
1031
1032 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1033 #define PK_FLT(src) (*(StgFloat *)(src))
1034
1035 #define ASSIGN_DBL(dst,src) \
1036       __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1037         "=m" (((P_)(dst))[1]) : "f" (src));
1038
1039 #define PK_DBL(src) \
1040     ( { register double d; \
1041       __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1042         "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1043     } )
1044
1045 #else /* ! sparc */
1046
1047 /* (not very) forward prototype declarations */
1048 void        ASSIGN_DBL PROTO((W_ [], StgDouble));
1049 StgDouble   PK_DBL     PROTO((W_ []));
1050 void        ASSIGN_FLT PROTO((W_ [], StgFloat));
1051 StgFloat    PK_FLT     PROTO((W_ []));
1052
1053 extern STG_INLINE
1054 void
1055 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1056 {
1057     double_thing y;
1058     y.d = src;
1059     p_dest[0] = y.du.dhi;
1060     p_dest[1] = y.du.dlo;
1061 }
1062
1063 /* GCC also works with this version, but it generates
1064    the same code as the previous one, and is not ANSI
1065
1066 #define ASSIGN_DBL( p_dest, src ) \
1067         *p_dest = ((double_thing) src).du.dhi; \
1068         *(p_dest+1) = ((double_thing) src).du.dlo \
1069 */
1070
1071 extern STG_INLINE
1072 StgDouble
1073 PK_DBL(W_ p_src[])
1074 {
1075     double_thing y;
1076     y.du.dhi = p_src[0];
1077     y.du.dlo = p_src[1];
1078     return(y.d);
1079 }
1080
1081 extern STG_INLINE
1082 void
1083 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1084 {
1085     float_thing y;
1086     y.f = src;
1087     *p_dest = y.fu;
1088 }
1089
1090 extern STG_INLINE
1091 StgFloat
1092 PK_FLT(W_ p_src[])
1093 {
1094     float_thing y;
1095     y.fu = *p_src;
1096     return(y.f);
1097 }
1098
1099 #endif /* ! sparc */
1100
1101 #endif /* __GNUC__ */
1102
1103 #endif /* not __m68k__ */
1104 \end{code}
1105
1106 %************************************************************************
1107 %*                                                                      *
1108 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1109 %*                                                                      *
1110 %************************************************************************
1111
1112 We regularly use this macro to fish the ``contents'' part
1113 out of a DATA or TUPLE closure, which is what is used for
1114 non-ptr and ptr arrays (respectively).
1115
1116 BYTE_ARR_CTS returns a @C_ *@!
1117
1118 We {\em ASSUME} we can use the same macro for both!!
1119 \begin{code}
1120
1121 #ifdef DEBUG
1122 #define BYTE_ARR_CTS(a)                                 \
1123  ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info);       \
1124     ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1125 #define PTRS_ARR_CTS(a)                                 \
1126  ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info)       \
1127         || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1128     ((a)+MUTUPLE_HS);} )
1129 #else
1130 #define BYTE_ARR_CTS(a)         ((char *) (((StgPtr) (a))+DATA_HS))
1131 #define PTRS_ARR_CTS(a)         ((a)+MUTUPLE_HS)
1132 #endif
1133
1134 /* sigh */
1135 extern I_ genSymZh(STG_NO_ARGS);
1136 extern I_ resetGenSymZh(STG_NO_ARGS);
1137 extern I_ incSeqWorldZh(STG_NO_ARGS);
1138
1139 /* sigh again: without these some (notably "float") willnae work */
1140 extern I_ long2bytes__   PROTO((long,   unsigned char *));
1141 extern I_ int2bytes__    PROTO((int,    unsigned char *));
1142 extern I_ short2bytes__  PROTO((short,  unsigned char *));
1143 extern I_ float2bytes__  PROTO((float,  unsigned char *));
1144 extern I_ double2bytes__ PROTO((double, unsigned char *));
1145
1146 /* these may not be necessary; and they create warnings (WDP) */
1147 extern I_ bytes2long__   PROTO((P_, I_ *));
1148 extern I_ bytes2int__    PROTO((P_, I_ *));
1149 extern I_ bytes2short__  PROTO((P_, I_ *));
1150 extern I_ bytes2float__  PROTO((P_, StgFloat *));
1151 extern I_ bytes2double__ PROTO((P_, StgDouble *));
1152
1153 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1154 \end{code}
1155
1156 OK, the easy ops first: (all except \tr{newArr*}:
1157
1158 (OLD:) VERY IMPORTANT! The read/write/index primitive ops
1159 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1160 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1161 This is because you might be trying to take apart a C struct, where
1162 the offset from the start of the struct isn't a multiple of the
1163 size of the thing you're getting.  Hence the @(char *)@ casts.
1164
1165 EVEN MORE IMPORTANT! The above is a lie.  The offsets for BlahArrays
1166 are in Blahs.  WDP 95/08
1167
1168 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1169 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1170
1171 In the case of @Array#@ (which contain pointers), the offset is in units
1172 of one ptr (not bytes).
1173
1174 \begin{code}
1175 #define sameMutableArrayZh(r,a,b)       r=(I_)((a)==(b))
1176 #define sameMutableByteArrayZh(r,a,b)   r=(I_)((B_)(a)==(B_)(b))
1177
1178 #define readArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1179
1180 #define readCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1181 #define readIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1182 #define readAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1183 #define readFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1184 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1185
1186 /* result ("r") arg ignored in write macros! */
1187 #define writeArrayZh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1188
1189 #define writeCharArrayZh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1190 #define writeIntArrayZh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1191 #define writeAddrArrayZh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1192 #define writeFloatArrayZh(a,i,v)  \
1193         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1194 #define writeDoubleArrayZh(a,i,v) \
1195         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1196
1197 #define indexArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1198
1199 #define indexCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1200 #define indexIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1201 #define indexAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1202 #define indexFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1203 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1204
1205 #define indexCharOffAddrZh(r,a,i)   r= ((C_ *)(a))[i]
1206 #define indexIntOffAddrZh(r,a,i)    r= ((I_ *)(a))[i]
1207 #define indexAddrOffAddrZh(r,a,i)   r= ((PP_)(a))[i]
1208 #define indexFloatOffAddrZh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1209 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1210
1211 /* Freezing arrays-of-ptrs requires changing an info table, for the
1212    benefit of the generational collector.  It needs to scavenge mutable
1213    objects, even if they are in old space.  When they become immutable,
1214    they can be removed from this scavenge list.  */
1215 #define unsafeFreezeArrayZh(r,a)                                \
1216         do {                                            \
1217         P_ result;                                      \
1218         result=(P_) (a);                                \
1219         FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info);   \
1220         r = result;                                     \
1221         }while(0)
1222
1223 #define unsafeFreezeByteArrayZh(r,a)    r=(B_)(a)
1224 \end{code}
1225
1226 Now the \tr{newArr*} ops:
1227
1228 \begin{code}
1229 /*
1230 --------------------
1231 Will: ToDo: we need to find suitable places to put this comment, and the
1232 "in-general" one which follows.
1233
1234 ************ Nota Bene.  The "n" in this macro is guaranteed to
1235 be a register, *not* (say) Node[1].  That means that it is guaranteed
1236 to survive GC, provided only that the register is kept unaltered.
1237 This is important, because "n" is used after the HEAP_CHK.
1238
1239 In general, *all* parameters to these primitive-op macros are always
1240 registers.  (Will: For exactly *which* primitive-op macros is this guaranteed?
1241 Exactly those which can trigger GC?)
1242 ------------------------
1243
1244 NOTE: the above may now be OLD (WDP 94/02/10)
1245 */
1246 \end{code}
1247
1248 For char arrays, the size is in {\em BYTES}.
1249
1250 \begin{code}
1251 #define newCharArrayZh(r,liveness,n)    newByteArray(r,liveness,(n) * sizeof(C_))
1252 #define newIntArrayZh(r,liveness,n)     newByteArray(r,liveness,(n) * sizeof(I_))
1253 #define newAddrArrayZh(r,liveness,n)    newByteArray(r,liveness,(n) * sizeof(P_))
1254 #define newFloatArrayZh(r,liveness,n)   newByteArray(r,liveness,(n) * sizeof(StgFloat))
1255 #define newDoubleArrayZh(r,liveness,n)  newByteArray(r,liveness,(n) * sizeof(StgDouble))
1256
1257 #define newByteArray(r,liveness,n)                              \
1258 {                                                               \
1259   P_ result;                                                    \
1260   I_ size;                                                      \
1261                                                                 \
1262   HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0);            \
1263   size = BYTES_TO_STGWORDS(n);                                  \
1264   ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */;    \
1265   CC_ALLOC(CCC,DATA_HS+size,ARR_K);                             \
1266                                                                 \
1267   result = Hp-(DATA_HS+size)+1;                                 \
1268   SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0);    \
1269   r = (B_) result;                                              \
1270 }
1271 \end{code}
1272
1273 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1274 The initialisation value is guaranteed to be in a register,
1275 and will be indicated by the liveness mask, so it's ok to do
1276 a \tr{HEAP_CHK}, which may trigger GC.
1277
1278 \begin{code}
1279 /* The new array initialization routine for the NCG */
1280 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1281
1282 #define newArrayZh(r,liveness,n,init)                   \
1283 {                                                       \
1284   P_ p;                                                 \
1285   P_ result;                                            \
1286                                                         \
1287   HEAP_CHK(liveness, MUTUPLE_HS+(n),0);                 \
1288   ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1289   CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */     \
1290                                                         \
1291   result = Hp + 1 - (MUTUPLE_HS+(n));                   \
1292   SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1293   for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1294         *p = (W_) (init);                               \
1295   }                                                     \
1296                                                         \
1297   r = result;                                           \
1298 }
1299 \end{code}
1300
1301 %************************************************************************
1302 %*                                                                      *
1303 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1304 %*                                                                      *
1305 %************************************************************************
1306
1307 \begin{code}
1308 ED_(Prelude_Z91Z93_closure);
1309
1310 #define newSynchVarZh(r, hp)                            \
1311 {                                                       \
1312   ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1313   CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */       \
1314   SET_SVAR_HDR(hp,EmptySVar_info,CCC);                  \
1315   SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = Prelude_Z91Z93_closure;      \
1316   r = hp;                                               \
1317 }
1318 \end{code}
1319
1320 \begin{code}
1321 #ifdef CONCURRENT
1322
1323 extern void Yield PROTO((W_));
1324
1325 #define takeMVarZh(r, liveness, node)                   \
1326 {                                                       \
1327   while (INFO_PTR(node) != (W_) FullSVar_info) {        \
1328     if (SVAR_HEAD(node) == Prelude_Z91Z93_closure)              \
1329       SVAR_HEAD(node) = CurrentTSO;                     \
1330     else                                                \
1331       TSO_LINK(SVAR_TAIL(node)) = CurrentTSO;           \
1332     TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure;         \
1333     SVAR_TAIL(node) = CurrentTSO;                       \
1334     DO_YIELD(liveness << 1);                            \
1335   }                                                     \
1336   SET_INFO_PTR(node, EmptySVar_info);                   \
1337   r = SVAR_VALUE(node);                                 \
1338   SVAR_VALUE(node) = Prelude_Z91Z93_closure;                    \
1339 }
1340
1341 #else
1342
1343 #define takeMVarZh(r, liveness, node)                   \
1344 {                                                       \
1345   if (INFO_PTR(node) != (W_) FullSVar_info) {           \
1346     /* Don't wrap the calls; we're done with STG land */\
1347     fflush(stdout);                                     \
1348     fprintf(stderr, "takeMVar#: MVar is empty.\n");     \
1349     EXIT(EXIT_FAILURE);                                 \
1350   }                                                     \
1351   SET_INFO_PTR(node, EmptySVar_info);                   \
1352   r = SVAR_VALUE(node);                                 \
1353   SVAR_VALUE(node) = Prelude_Z91Z93_closure;                    \
1354 }
1355
1356 #endif
1357 \end{code}
1358
1359 \begin{code}
1360 #ifdef CONCURRENT
1361
1362 #ifdef GRAN
1363
1364 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1365 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1366 /* the CurrentProc. This means we have an implicit context switch after */
1367 /* putMVar even if unfair scheduling is used in GranSim (default)!  -- HWL */
1368
1369 #define putMVarZh(node, value)                          \
1370 {                                                       \
1371   P_ tso;                                               \
1372   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1373     /* Don't wrap the calls; we're done with STG land */\
1374     fflush(stdout);                                     \
1375     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1376     EXIT(EXIT_FAILURE);                                 \
1377   }                                                     \
1378   SET_INFO_PTR(node, FullSVar_info);                    \
1379   SVAR_VALUE(node) = value;                             \
1380   tso = SVAR_HEAD(node);                                \
1381   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1382     if (DO_QP_PROF)                                     \
1383       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1384     if (ThreadQueueHd == Prelude_Z91Z93_closure)                \
1385       ThreadQueueHd = tso;                      \
1386     else                                                \
1387       TSO_LINK(ThreadQueueTl) = tso;            \
1388     ThreadQueueTl = tso;                                \
1389     SVAR_HEAD(node) = TSO_LINK(tso);                    \
1390     TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure;                        \
1391     if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure)                  \
1392       SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure;            \
1393   }                                                     \
1394 }
1395
1396 #else /* !GRAN */
1397
1398 #define putMVarZh(node, value)                          \
1399 {                                                       \
1400   P_ tso;                                               \
1401   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1402     /* Don't wrap the calls; we're done with STG land */\
1403     fflush(stdout);                                     \
1404     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1405     EXIT(EXIT_FAILURE);                                 \
1406   }                                                     \
1407   SET_INFO_PTR(node, FullSVar_info);                    \
1408   SVAR_VALUE(node) = value;                             \
1409   tso = SVAR_HEAD(node);                                \
1410   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1411     if (DO_QP_PROF)                                     \
1412       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1413     if (RunnableThreadsHd == Prelude_Z91Z93_closure)            \
1414       RunnableThreadsHd = tso;                          \
1415     else                                                \
1416       TSO_LINK(RunnableThreadsTl) = tso;                \
1417     RunnableThreadsTl = tso;                            \
1418     SVAR_HEAD(node) = TSO_LINK(tso);                    \
1419     TSO_LINK(tso) = (P_) Prelude_Z91Z93_closure;                        \
1420     if(SVAR_HEAD(node) == (P_) Prelude_Z91Z93_closure)                  \
1421       SVAR_TAIL(node) = (P_) Prelude_Z91Z93_closure;            \
1422   }                                                     \
1423 }
1424
1425 #endif  /* GRAN */
1426
1427 #else
1428
1429 #define putMVarZh(node, value)                          \
1430 {                                                       \
1431   P_ tso;                                               \
1432   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1433     /* Don't wrap the calls; we're done with STG land */\
1434     fflush(stdout);                                     \
1435     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1436     EXIT(EXIT_FAILURE);                                 \
1437   }                                                     \
1438   SET_INFO_PTR(node, FullSVar_info);                    \
1439   SVAR_VALUE(node) = value;                             \
1440 }
1441
1442 #endif
1443 \end{code}
1444
1445 \begin{code}
1446 #ifdef CONCURRENT
1447
1448 #define readIVarZh(r, liveness, node)                   \
1449 {                                                       \
1450   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1451     if (SVAR_HEAD(node) == Prelude_Z91Z93_closure)              \
1452       SVAR_HEAD(node) = CurrentTSO;                     \
1453     else                                                \
1454       TSO_LINK(SVAR_TAIL(node)) = CurrentTSO;           \
1455     TSO_LINK(CurrentTSO) = (P_) Prelude_Z91Z93_closure;         \
1456     SVAR_TAIL(node) = CurrentTSO;                       \
1457     DO_YIELD(liveness << 1);                            \
1458   }                                                     \
1459   r = SVAR_VALUE(node);                                 \
1460 }
1461
1462 #else
1463
1464 #define readIVarZh(r, liveness, node)                   \
1465 {                                                       \
1466   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1467     /* Don't wrap the calls; we're done with STG land */\
1468     fflush(stdout);                                     \
1469     fprintf(stderr, "readIVar#: IVar is empty.\n");     \
1470     EXIT(EXIT_FAILURE);                                 \
1471   }                                                     \
1472   r = SVAR_VALUE(node);                                 \
1473 }
1474
1475 #endif
1476 \end{code}
1477
1478 \begin{code}
1479 #ifdef CONCURRENT
1480
1481 #ifdef GRAN
1482
1483 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1484 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1485 /* the CurrentProc. This means we have an implicit context switch after */
1486 /* writeIVar even if unfair scheduling is used in GranSim (default)!  -- HWL */
1487
1488 #define writeIVarZh(node, value)                        \
1489 {                                                       \
1490   P_ tso;                                               \
1491   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1492     /* Don't wrap the calls; we're done with STG land */\
1493     fflush(stdout);                                     \
1494     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1495     EXIT(EXIT_FAILURE);                                 \
1496   }                                                     \
1497   tso = SVAR_HEAD(node);                                \
1498   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1499     if (ThreadQueueHd == Prelude_Z91Z93_closure)                \
1500       ThreadQueueHd = tso;                      \
1501     else                                                \
1502       TSO_LINK(ThreadQueueTl) = tso;            \
1503     while(TSO_LINK(tso) != Prelude_Z91Z93_closure) {            \
1504       if (DO_QP_PROF)                                   \
1505         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1506       tso = TSO_LINK(tso);                              \
1507     }                                                   \
1508     if (DO_QP_PROF)                                     \
1509       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1510     ThreadQueueTl = tso;                                \
1511   }                                                     \
1512   /* Don't use freeze, since it's conditional on GC */  \
1513   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1514   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1515   SVAR_VALUE(node) = value;                             \
1516 }
1517
1518 #else /* !GRAN */
1519
1520 #define writeIVarZh(node, value)                        \
1521 {                                                       \
1522   P_ tso;                                               \
1523   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1524     /* Don't wrap the calls; we're done with STG land */\
1525     fflush(stdout);                                     \
1526     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1527     EXIT(EXIT_FAILURE);                                 \
1528   }                                                     \
1529   tso = SVAR_HEAD(node);                                \
1530   if (tso != (P_) Prelude_Z91Z93_closure) {                     \
1531     if (RunnableThreadsHd == Prelude_Z91Z93_closure)            \
1532       RunnableThreadsHd = tso;                          \
1533     else                                                \
1534       TSO_LINK(RunnableThreadsTl) = tso;                \
1535     while(TSO_LINK(tso) != Prelude_Z91Z93_closure) {            \
1536       if (DO_QP_PROF)                                   \
1537         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1538       tso = TSO_LINK(tso);                              \
1539     }                                                   \
1540     if (DO_QP_PROF)                                     \
1541       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1542     RunnableThreadsTl = tso;                            \
1543   }                                                     \
1544   /* Don't use freeze, since it's conditional on GC */  \
1545   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1546   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1547   SVAR_VALUE(node) = value;                             \
1548 }
1549
1550 #endif  /* GRAN */
1551
1552 #else
1553
1554 #define writeIVarZh(node, value)                        \
1555 {                                                       \
1556   P_ tso;                                               \
1557   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1558     /* Don't wrap the calls; we're done with STG land */\
1559     fflush(stdout);                                     \
1560     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1561     EXIT(EXIT_FAILURE);                                 \
1562   }                                                     \
1563   /* Don't use freeze, since it's conditional on GC */  \
1564   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1565   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1566   SVAR_VALUE(node) = value;                             \
1567 }
1568
1569 #endif
1570 \end{code}
1571
1572 %************************************************************************
1573 %*                                                                      *
1574 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1575 %*                                                                      *
1576 %************************************************************************
1577
1578 \begin{code}
1579 #ifdef CONCURRENT
1580
1581 /* ToDo: for GRAN */
1582
1583 #define delayZh(liveness, us)                           \
1584   {                                                     \
1585     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1586       WaitingThreadsHd = CurrentTSO;                    \
1587     else                                                \
1588       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1589     WaitingThreadsTl = CurrentTSO;                      \
1590     TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;                      \
1591     TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1592     DO_YIELD(liveness << 1);                            \
1593   }
1594
1595 #else
1596
1597 #define delayZh(liveness, us)                           \
1598   {                                                     \
1599     fflush(stdout);                                     \
1600     fprintf(stderr, "delay#: unthreaded build.\n");     \
1601     EXIT(EXIT_FAILURE);                                 \
1602   }
1603
1604 #endif
1605
1606 #ifdef CONCURRENT
1607
1608 /* ToDo: something for GRAN */
1609
1610 #define waitReadZh(liveness, fd)                        \
1611   {                                                     \
1612     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1613       WaitingThreadsHd = CurrentTSO;                    \
1614     else                                                \
1615       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1616     WaitingThreadsTl = CurrentTSO;                      \
1617     TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;                      \
1618     TSO_EVENT(CurrentTSO) = (W_) (-(fd));               \
1619     DO_YIELD(liveness << 1);                            \
1620   }
1621
1622 #else
1623
1624 #define waitReadZh(liveness, fd)                        \
1625   {                                                     \
1626     fflush(stdout);                                     \
1627     fprintf(stderr, "waitRead#: unthreaded build.\n");  \
1628     EXIT(EXIT_FAILURE);                                 \
1629   }
1630
1631 #endif
1632
1633 #ifdef CONCURRENT
1634
1635 /* ToDo: something for GRAN */
1636
1637 #ifdef HAVE_SYS_TYPES_H
1638 #include <sys/types.h>
1639 #endif  HAVE_SYS_TYPES_H */
1640
1641 #define waitWriteZh(liveness, fd)                       \
1642   {                                                     \
1643     if (WaitingThreadsTl == Prelude_Z91Z93_closure)             \
1644       WaitingThreadsHd = CurrentTSO;                    \
1645     else                                                \
1646       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1647     WaitingThreadsTl = CurrentTSO;                      \
1648     TSO_LINK(CurrentTSO) = Prelude_Z91Z93_closure;                      \
1649     TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE));    \
1650     DO_YIELD(liveness << 1);                            \
1651   }
1652
1653 #else
1654
1655 #define waitWriteZh(liveness, fd)                       \
1656   {                                                     \
1657     fflush(stdout);                                     \
1658     fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1659     EXIT(EXIT_FAILURE);                                 \
1660   }
1661
1662 #endif
1663
1664 \end{code}
1665
1666 %************************************************************************
1667 %*                                                                      *
1668 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1669 %*                                                                      *
1670 %************************************************************************
1671
1672 \begin{code}
1673 extern P_ TopClosure;
1674 EXTFUN(ErrorIO_innards);
1675 EXTFUN(__std_entry_error__);
1676
1677 #define errorIOZh(a)            \
1678     do { TopClosure=(a);        \
1679          (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1680          (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1681          JMP_(ErrorIO_innards); \
1682     } while(0)
1683
1684 #if !defined(CALLER_SAVES_SYSTEM)
1685 /* can use the macros */
1686 #define stg_getc(stream)        getc((FILE *) (stream))
1687 #define stg_putc(c,stream)      putc((c),((FILE *) (stream)))
1688 #else
1689 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1690 #define stg_getc(stream)        SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1691 #define stg_putc(c,stream)      SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1692 #endif
1693
1694 int initialize_virtual_timer(int us);
1695 int install_segv_handler(STG_NO_ARGS);
1696 int install_vtalrm_handler(STG_NO_ARGS);
1697 void initUserSignals(STG_NO_ARGS);
1698 void blockUserSignals(STG_NO_ARGS);
1699 void unblockUserSignals(STG_NO_ARGS);
1700 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1701 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1702 IF_RTS(void AwaitEvent(I_ delta);)
1703
1704 #ifdef _POSIX_SOURCE
1705 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1706 #define stg_sig_ignore(s,m)     SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1707 #define stg_sig_default(s,m)    SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1708 #define stg_sig_catch(s,sp,m)   SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1709 #else
1710 extern I_ sig_install PROTO((I_, I_));
1711 #define stg_sig_ignore(s,m)     SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1712 #define stg_sig_default(s,m)    SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1713 #define stg_sig_catch(s,sp,m)   SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1714 #endif
1715
1716 #define STG_SIG_DFL     (-1)
1717 #define STG_SIG_IGN     (-2)
1718 #define STG_SIG_ERR     (-3)
1719
1720 StgInt getErrorHandler(STG_NO_ARGS);
1721 #ifndef PAR
1722 void raiseError PROTO((StgStablePtr handler));
1723 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1724 #endif
1725 void decrementErrorCount(STG_NO_ARGS);
1726
1727 #define stg_catchError(sp)      SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1728 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1729 \end{code}
1730
1731 %************************************************************************
1732 %*                                                                      *
1733 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1734 %*                                                                      *
1735 %************************************************************************
1736
1737
1738 The type of these should be:
1739
1740 \begin{verbatim}
1741 makeStablePointer#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1742 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1743 \end{verbatim}
1744
1745 Since world-tokens are no longer explicitly passed around, the
1746 implementations have a few less arguments/results.
1747
1748 The simpler one is @deRefStablePointer#@ (which is only a primop
1749 because it is more polymorphic than is allowed of a ccall).
1750
1751 \begin{code}
1752 #ifdef PAR
1753
1754 #define deRefStablePtrZh(ri,sp)                                     \
1755 do {                                                                \
1756     fflush(stdout);                                                 \
1757     fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1758     EXIT(EXIT_FAILURE);                                             \
1759 } while(0)
1760
1761 #else /* !PAR */
1762
1763 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1764
1765 #define deRefStablePtrZh(ri,sp) \
1766    ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1767
1768 \end{code}
1769
1770 Declarations for other stable pointer operations.
1771
1772 \begin{code}
1773 void    freeStablePointer       PROTO((I_ stablePtr));
1774
1775 void    enterStablePtr          PROTO((StgStablePtr, StgFunPtr));
1776 void    performIO               PROTO((StgStablePtr));
1777 I_      enterInt                PROTO((StgStablePtr));
1778 I_      enterFloat              PROTO((StgStablePtr));
1779 P_      deRefStablePointer      PROTO((StgStablePtr));
1780 IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
1781 IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
1782 IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
1783 IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
1784
1785 EXTFUN(stopPerformIODirectReturn);
1786 EXTFUN(startPerformIO);
1787 EXTFUN(stopEnterIntDirectReturn);
1788 EXTFUN(startEnterInt);
1789 EXTFUN(stopEnterFloatDirectReturn);
1790 EXTFUN(startEnterFloat);
1791
1792 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1793
1794 #endif /* !PAR */
1795
1796 IF_RTS(extern I_ ErrorIO_call_count;)
1797 \end{code}
1798
1799 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1800 if we're unlucky, it will have to allocate a new table and copy the
1801 old bit over.  Since we might, very occasionally, have to call the
1802 garbage collector, this has to be a macro... sigh!
1803
1804 NB @newSP@ is required because it is entirely possible that
1805 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1806 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1807
1808 Another obscure piece of coding is the recalculation of the size of
1809 the table.  We do this just in case Jim's threads decide they want to
1810 context switch---in which case any stack-allocated variables may get
1811 trashed.  (If only there was a special heap check which didn't
1812 consider context switching...)
1813
1814 \begin{code}
1815 #ifndef PAR
1816
1817 /* Calculate SP Table size from number of pointers */
1818 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1819
1820 /* Calculate number of pointers in new table from number in old table:
1821    any strictly increasing expression will do here */
1822 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1823
1824 extern void enlargeSPTable PROTO((P_, P_));
1825
1826 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1827 do {                                                                \
1828   EXTDATA_RO(StablePointerTable_info);                              \
1829   EXTDATA(UnusedSP);                                                \
1830   StgStablePtr newSP;                                               \
1831                                                                     \
1832   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1833     { /* Variables used before the heap check */                    \
1834       I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1835       I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs );                   \
1836       I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs );                  \
1837       HEAP_CHK(liveness, _FHS+NewSize, 0);                          \
1838     }                                                               \
1839     { /* Variables used after the heap check - same values */       \
1840       I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1841       I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs );                   \
1842       I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs );                  \
1843       P_ SPTable = Hp + 1 - (_FHS + NewSize);                       \
1844                                                                     \
1845       CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */             \
1846       SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1847       SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
1848       StorageMgrInfo.StablePointerTable = SPTable;                  \
1849     }                                                               \
1850   }                                                                 \
1851                                                                     \
1852   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);               \
1853   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1854   CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable );           \
1855   stablePtr = newSP;                                                \
1856 } while (0)
1857
1858 #else
1859
1860 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1861 do {                                                                \
1862     fflush(stdout);                                                 \
1863     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1864     EXIT(EXIT_FAILURE);                                             \
1865 } while(0)
1866
1867 #endif /* !PAR */
1868 \end{code}
1869
1870 %************************************************************************
1871 %*                                                                      *
1872 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1873 %*                                                                      *
1874 %************************************************************************
1875
1876 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1877 can expect three parameters: the two arguments and a "register" to put
1878 the result into.
1879
1880 Message to Will: This primop breaks referential transparency so badly
1881 you might want to leave it out.  On the other hand, if you hide it
1882 away in an appropriate monad, it's perfectly safe. [ADR]
1883
1884 Note that this primop is non-deterministic: different results can be
1885 obtained depending on just what the garbage collector (and code
1886 optimiser??) has done.  However, we can guarantee that if two objects
1887 are pointer-equal, they have the same denotation --- the converse most
1888 certainly doesn't hold.
1889
1890 ToDo ADR: The degree of non-determinism could be greatly reduced by
1891 following indirections.
1892
1893 \begin{code}
1894 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1895 \end{code}
1896
1897 %************************************************************************
1898 %*                                                                      *
1899 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1900 %*                                                                      *
1901 %************************************************************************
1902
1903 Assuming local sparking in some form, we can now inline the spark request.
1904
1905 We build a doubly-linked list in the heap, so that we can handle FIFO
1906 or LIFO scheduling as we please.
1907
1908 Anything with tag >= 0 is in WHNF, so we discard it.
1909
1910 \begin{code}
1911 #ifdef CONCURRENT
1912
1913 ED_(Prelude_Z91Z93_closure);
1914 ED_(True_closure);
1915
1916 #if defined(GRAN)
1917 #define parZh(r,node)                           \
1918         PARZh(r,node,1,0,0,0,0,0)
1919
1920 #define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1921         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
1922
1923 #define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1924         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
1925
1926 #define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1927         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
1928
1929 #define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
1930         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
1931
1932 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local)        \
1933 {                                                       \
1934   sparkq result;                                                \
1935   if (SHOULD_SPARK(node)) {                             \
1936     SaveAllStgRegs();                                   \
1937     { sparkq result;                                            \
1938       result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);        \
1939       if (local==2) {         /* special case for parAtAbs */   \
1940         GranSimSparkAtAbs(result,(I_)where,identifier);\
1941       } else if (local==3) {  /* special case for parAtRel */   \
1942         GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier);   \
1943       } else {       \
1944         GranSimSparkAt(result,where,identifier);        \
1945       }        \
1946       context_switch = 1;                               \
1947     }                                                   \
1948     RestoreAllStgRegs();                                \
1949   } else if (do_qp_prof) {                              \
1950     I_ tid = threadId++;                                \
1951     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1952   }                                                     \
1953   r = 1; /* return code for successful spark -- HWL */  \
1954 }
1955
1956 #define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1957         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
1958
1959 #define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1960         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
1961
1962 #if 1
1963
1964 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1965 {                                                       \
1966   if (SHOULD_SPARK(node)) {                             \
1967     SaveAllStgRegs();                                   \
1968     { sparkq result;                                            \
1969       result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1970       add_to_spark_queue(result);                               \
1971       GranSimSpark(local,(P_)node);                                     \
1972       context_switch = 1;                               \
1973     }                                                   \
1974     RestoreAllStgRegs();                                \
1975   } else if (do_qp_prof) {                              \
1976     I_ tid = threadId++;                                \
1977     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1978   }                                                     \
1979   r = 1; /* return code for successful spark -- HWL */  \
1980 }
1981
1982 #else
1983
1984 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1985 {                                                       \
1986   sparkq result;                                                \
1987   if (SHOULD_SPARK(node)) {                             \
1988     result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1989     ADD_TO_SPARK_QUEUE(result);                         \
1990     SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node);        \
1991     /* context_switch = 1;  not needed any more -- HWL */       \
1992   } else if (do_qp_prof) {                              \
1993     I_ tid = threadId++;                                \
1994     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1995   }                                                     \
1996   r = 1; /* return code for successful spark -- HWL */  \
1997 }
1998
1999 #endif
2000
2001 #define copyableZh(r,node)                              \
2002   /* copyable not yet implemented!! */
2003
2004 #define noFollowZh(r,node)                              \
2005   /* noFollow not yet implemented!! */
2006
2007 #else  /* !GRAN */
2008
2009 extern I_ required_thread_count;
2010
2011 #ifdef PAR
2012 #define COUNT_SPARK     TSO_GLOBALSPARKS(CurrentTSO)++
2013 #else
2014 #define COUNT_SPARK
2015 #endif
2016
2017 /*
2018    Note that we must bump the required thread count NOW, rather
2019    than when the thread is actually created.
2020  */
2021
2022 #define forkZh(r,liveness,node)                         \
2023 {                                                       \
2024   while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
2025     DO_YIELD((liveness << 1) | 1);                      \
2026   COUNT_SPARK;                                          \
2027   if (SHOULD_SPARK(node)) {                             \
2028     *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node);     \
2029   } else if (DO_QP_PROF) {                              \
2030     I_ tid = threadId++;                                \
2031     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
2032   }                                                     \
2033   required_thread_count++;                              \
2034   context_switch = 1;                                   \
2035   r = 1; /* Should not be necessary */                  \
2036 }
2037
2038 #define parZh(r,node)                                   \
2039 {                                                       \
2040   COUNT_SPARK;                                          \
2041   if (SHOULD_SPARK(node) &&                             \
2042    PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) {  \
2043     *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node);     \
2044   } else {                                              \
2045     sparksIgnored++;                                    \
2046     if (DO_QP_PROF) {                                   \
2047       I_ tid = threadId++;                              \
2048       SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);   \
2049     }                                                   \
2050   }                                                     \
2051   r = 1; /* Should not be necessary */                  \
2052 }
2053
2054 #endif  /* GRAN */
2055 \end{code}
2056
2057 The following seq# code should only be used in unoptimized code.
2058 Be warned: it's a potential bug-farm.
2059
2060 First we push two words on the B stack: the current value of RetReg
2061 (which may or may not be live), and a continuation snatched largely out
2062 of thin air (it's a point within this code block).  Then we set RetReg
2063 to the special polymorphic return code for seq, load up Node with the
2064 closure to be evaluated, and we're off.  When the eval returns to the
2065 polymorphic seq return point, the two words are popped off the B stack,
2066 RetReg is restored, and we jump to the continuation, completing the
2067 primop and going on our merry way.
2068
2069 \begin{code}
2070
2071 ED_RO_(vtbl_seq);
2072
2073 #define seqZh(r,liveness,node)              \
2074   ({                                        \
2075     __label__ cont;                         \
2076     /* STK_CHK(liveness,0,2,0,0,0,0); */    \
2077     /* SpB -= BREL(2); */                   \
2078     SpB[BREL(0)] = (W_) RetReg;             \
2079     SpB[BREL(1)] = (W_) &&cont;             \
2080     RetReg = (StgRetAddr) vtbl_seq;         \
2081     Node = node;                            \
2082     ENT_VIA_NODE();                         \
2083     InfoPtr = (D_)(INFO_PTR(Node));         \
2084     JMP_(ENTRY_CODE(InfoPtr));              \
2085     cont:                                   \
2086     r = 1; /* Should be unnecessary */      \
2087   })
2088
2089 #endif  /* CONCURRENT */
2090 \end{code}
2091
2092 %************************************************************************
2093 %*                                                                      *
2094 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2095 %*                                                                      *
2096 %************************************************************************
2097
2098 [Based on previous MallocPtr comments -- SOF]
2099
2100 This macro is used to construct a ForeignObj on the heap.
2101
2102 What this does is plug the pointer (which will be in a local
2103 variable) together with its finalising/free routine, into a fresh heap
2104 object and then sets a result (which will be a register) to point
2105 to the fresh heap object.
2106
2107 To accommodate per-object finalisation, augment the macro with a
2108 finalisation routine argument. Nothing spectacular, just plug the
2109 pointer to the routine into the ForeignObj -- SOF 4/96
2110
2111 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2112 too?  (It's if you want to use the SPAT profiling tools to
2113 characterize program behavior by ``activity'' -- tail-calling,
2114 heap-checking, etc. -- see Ticky.lh.  It is quite specialized.
2115 WDP 95/1)
2116
2117 (Swapped first two arguments to make it come into line with what appears
2118 to be `standard' format, return register then liveness mask. -- SOF 4/96)
2119
2120 \begin{code}
2121 #ifndef PAR
2122
2123 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2124
2125 #define makeForeignObjZh(r, liveness, mptr, finalise)    \
2126 do {                                                     \
2127   P_ result;                                             \
2128                                                          \
2129   HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0);              \
2130   CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */   \
2131                                                                    \
2132   result = Hp + 1 - (_FHS + ForeignObj_SIZE);                      \
2133   SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
2134   ForeignObj_CLOSURE_DATA(result)      = (P_)mptr;                 \
2135   ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise;             \
2136   ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
2137   StorageMgrInfo.ForeignObjList = result;                          \
2138                                                         \
2139 /*                                                      \
2140   printf("DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n",        \
2141       result,                                           \
2142       result[0],result[1],                              \
2143       result[2],result[3]);                             \
2144 */                                                      \
2145   CHECK_ForeignObj_CLOSURE( result );                   \
2146   VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2147                                                         \
2148   (r) = (P_) result;                                    \
2149 } while (0)
2150
2151 #else
2152 #define makeForeignObjZh(r, liveness, mptr, finalise)               \
2153 do {                                                                \
2154     fflush(stdout);                                                 \
2155     fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2156     EXIT(EXIT_FAILURE);                                             \
2157 } while(0)
2158
2159 #endif /* !PAR */
2160 \end{code}
2161
2162
2163 End-of-file's multi-slurp protection:
2164 \begin{code}
2165 #endif /* ! STGMACROS_H */
2166 \end{code}