ghc/includes/StgMacros.lh

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