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 \end{code}
 823
 824 Then there are a few oddments to make life easier:
 825 \begin{code}
 826 /*
 827    DIRE WARNING.
 828    The "str" argument must be a literal C string.
 829
 830         addr2Integer( ..., "foo")   OK!
 831
 832         x = "foo";
 833         addr2Integer( ..., x)       NO! NO!
 834 */
 835
 836 #define addr2IntegerZh(ar,sr,dr, liveness, str)                                 \
 837 { MP_INT result;                                                                \
 838   /* taking the number of bytes/8 as the number of words of lookahead           \
 839      is plenty conservative */                                                  \
 840   I_ space = GMP_SAME_SIZE(sizeof(str) / 8 + 1);                                \
 841                                                                                 \
 842   GMP_HEAP_LOOKAHEAD(liveness, space);                                          \
 843                                                                                 \
 844   /* Perform the operation */                                                   \
 845   if (SAFESTGCALL3(I_,(void *, MP_INT *, char *, int), mpz_init_set_str,&result,(str),/*base*/10)) \
 846       abort();                                                                  \
 847                                                                                 \
 848   GMP_HEAP_HANDBACK();          /* restore Hp */                                \
 849   (ar) = result.alloc;                                                          \
 850   (sr) = result.size;                                                           \
 851   (dr) = (B_) (result.d - DATA_HS);                                             \
 852   /* pt to *beginning* of object (GMP has been monkeying around in the middle) */ \
 853 }
 854 \end{code}
 855
 856 Encoding and decoding float-ish things is pretty Integer-ish.  We use
 857 these pretty magical support functions, essentially stolen from Lennart:
 858 \begin{code}
 859 StgFloat  __encodeFloat  PROTO((MP_INT *, I_));
 860 void      __decodeFloat  PROTO((MP_INT * /*result1*/,
 861                                 I_ * /*result2*/,
 862                                 StgFloat));
 863
 864 StgDouble __encodeDouble PROTO((MP_INT *, I_));
 865 void      __decodeDouble PROTO((MP_INT * /*result1*/,
 866                                 I_ * /*result2*/,
 867                                 StgDouble));
 868 \end{code}
 869
 870 Some floating-point format info, made with the \tr{enquire} program
 871 (version~4.3) [comes with gcc].
 872 \begin{code}
 873 /* this should be done by CPU architecture, insofar as possible [WDP] */
 874
 875 #if sparc_TARGET_ARCH   \
 876  || alpha_TARGET_ARCH   \
 877  || hppa1_1_TARGET_ARCH \
 878  || i386_TARGET_ARCH    \
 879  || m68k_TARGET_ARCH    \
 880  || mipsel_TARGET_ARCH  \
 881  || mipseb_TARGET_ARCH  \
 882  || powerpc_TARGET_ARCH \
 883  || rs6000_TARGET_ARCH
 884
 885 /* yes, it is IEEE floating point */
 886 #include "ieee-flpt.h"
 887
 888 #if alpha_TARGET_ARCH   \
 889  || i386_TARGET_ARCH            \
 890  || mipsel_TARGET_ARCH
 891
 892 #undef BIGENDIAN /* little-endian weirdos... */
 893 #else
 894 #define BIGENDIAN 1
 895 #endif
 896
 897 #else /* unknown floating-point format */
 898
 899 ******* ERROR *********** Any ideas about floating-point format?
 900
 901 #endif /* unknown floating-point */
 902 \end{code}
 903
 904 \begin{code}
 905 #if alpha_TARGET_ARCH
 906 #define encodeFloatZh(r, hp, aa,sa,da, expon)   encodeDoubleZh(r, hp, aa,sa,da, expon)
 907 #else
 908 #define encodeFloatZh(r, hp, aa,sa,da, expon)   \
 909 { MP_INT arg;                                   \
 910   /* Does not allocate memory */                \
 911                                                 \
 912   arg.alloc     = aa;                           \
 913   arg.size      = sa;                           \
 914   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 915                                                 \
 916   r = SAFESTGCALL2(StgFloat,(void *, MP_INT *, I_), __encodeFloat,&arg,(expon));        \
 917 }
 918 #endif /* ! alpha */
 919
 920 #define encodeDoubleZh(r, hp, aa,sa,da, expon)  \
 921 { MP_INT arg;                                   \
 922   /* Does not allocate memory */                \
 923                                                 \
 924   arg.alloc     = aa;                           \
 925   arg.size      = sa;                           \
 926   arg.d         = (unsigned long int *) (BYTE_ARR_CTS(da)); \
 927                                                 \
 928   r = SAFESTGCALL2(StgDouble,(void *, MP_INT *, I_), __encodeDouble,&arg,(expon));\
 929 }
 930
 931 #if alpha_TARGET_ARCH
 932 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)  decodeDoubleZh(exponr, ar,sr,dr, hp, f)
 933 #else
 934 #define decodeFloatZh(exponr, ar,sr,dr, hp, f)                          \
 935 { MP_INT mantissa;                                                      \
 936   I_ exponent;                                                          \
 937   StgFloat arg = (f);                                                   \
 938                                                                         \
 939   /* Be prepared to tell Lennart-coded __decodeFloat    */              \
 940   /* where mantissa.d can be put (it does not care about the rest) */   \
 941   SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);     \
 942   mantissa.d = (hp) + DATA_HS;                                          \
 943                                                                         \
 944   /* Perform the operation */                                           \
 945   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgFloat),__decodeFloat,&mantissa,&exponent,arg);          \
 946   exponr= exponent;                                                     \
 947   ar    = mantissa.alloc;                                               \
 948   sr    = mantissa.size;                                                \
 949   dr    = (B_)(hp);                                                     \
 950 }
 951 #endif /* !alpha */
 952
 953 #define decodeDoubleZh(exponr, ar,sr,dr, hp, f)                         \
 954 { MP_INT mantissa;                                                      \
 955   I_ exponent;                                                          \
 956   StgDouble arg = (f);                                                  \
 957                                                                         \
 958   /* Be prepared to tell Lennart-coded __decodeDouble   */              \
 959   /* where mantissa.d can be put (it does not care about the rest) */   \
 960   SET_DATA_HDR(hp,ArrayOfData_info,CCC,DATA_VHS+MIN_MP_INT_SIZE,0);     \
 961   mantissa.d = (hp) + DATA_HS;                                          \
 962                                                                         \
 963   /* Perform the operation */                                           \
 964   SAFESTGCALL3(void,(void *, MP_INT *, I_ *, StgDouble),__decodeDouble,&mantissa,&exponent,arg);                \
 965   exponr= exponent;                                                     \
 966   ar    = mantissa.alloc;                                               \
 967   sr    = mantissa.size;                                                \
 968   dr    = (B_)(hp);                                                     \
 969 }
 970 \end{code}
 971
 972 %************************************************************************
 973 %*                                                                      *
 974 \subsubsection[StgMacros-mv-floats]{Moving floats and doubles around (e.g., to/from stacks)}
 975 %*                                                                      *
 976 %************************************************************************
 977
 978 With GCC, we use magic non-standard inlining; for other compilers, we
 979 just use functions (see also \tr{runtime/prims/PrimArith.lc}).
 980
 981 (The @OMIT_...@ is only used in compiling some of the RTS, none of
 982 which uses these anyway.)
 983
 984 \begin{code}
 985 #if alpha_TARGET_ARCH   \
 986  || i386_TARGET_ARCH    \
 987  || m68k_TARGET_ARCH
 988
 989 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
 990 #define PK_FLT(src) (*(StgFloat *)(src))
 991
 992 #define ASSIGN_DBL(dst, src) *(StgDouble *)(dst) = (src);
 993 #define PK_DBL(src) (*(StgDouble *)(src))
 994
 995 #else   /* not m68k || alpha || i[34]86 */
 996
 997 /* Special handling for machines with troublesome alignment constraints */
 998
 999 #define FLOAT_ALIGNMENT_TROUBLES    TRUE
1000
1001 #if ! defined(__GNUC__) || ! defined(__STG_GCC_REGS__)
1002
1003 void        ASSIGN_DBL PROTO((W_ [], StgDouble));
1004 StgDouble   PK_DBL     PROTO((W_ []));
1005 void        ASSIGN_FLT PROTO((W_ [], StgFloat));
1006 StgFloat    PK_FLT     PROTO((W_ []));
1007
1008 #else /* yes, its __GNUC__ && we really want them */
1009
1010 #if sparc_TARGET_ARCH
1011
1012 #define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
1013 #define PK_FLT(src) (*(StgFloat *)(src))
1014
1015 #define ASSIGN_DBL(dst,src) \
1016       __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
1017         "=m" (((P_)(dst))[1]) : "f" (src));
1018
1019 #define PK_DBL(src) \
1020     ( { register double d; \
1021       __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
1022         "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
1023     } )
1024
1025 #else /* ! sparc */
1026
1027 /* (not very) forward prototype declarations */
1028 void        ASSIGN_DBL PROTO((W_ [], StgDouble));
1029 StgDouble   PK_DBL     PROTO((W_ []));
1030 void        ASSIGN_FLT PROTO((W_ [], StgFloat));
1031 StgFloat    PK_FLT     PROTO((W_ []));
1032
1033 extern STG_INLINE
1034 void
1035 ASSIGN_DBL(W_ p_dest[], StgDouble src)
1036 {
1037     double_thing y;
1038     y.d = src;
1039     p_dest[0] = y.du.dhi;
1040     p_dest[1] = y.du.dlo;
1041 }
1042
1043 /* GCC also works with this version, but it generates
1044    the same code as the previous one, and is not ANSI
1045
1046 #define ASSIGN_DBL( p_dest, src ) \
1047         *p_dest = ((double_thing) src).du.dhi; \
1048         *(p_dest+1) = ((double_thing) src).du.dlo \
1049 */
1050
1051 extern STG_INLINE
1052 StgDouble
1053 PK_DBL(W_ p_src[])
1054 {
1055     double_thing y;
1056     y.du.dhi = p_src[0];
1057     y.du.dlo = p_src[1];
1058     return(y.d);
1059 }
1060
1061 extern STG_INLINE
1062 void
1063 ASSIGN_FLT(W_ p_dest[], StgFloat src)
1064 {
1065     float_thing y;
1066     y.f = src;
1067     *p_dest = y.fu;
1068 }
1069
1070 extern STG_INLINE
1071 StgFloat
1072 PK_FLT(W_ p_src[])
1073 {
1074     float_thing y;
1075     y.fu = *p_src;
1076     return(y.f);
1077 }
1078
1079 #endif /* ! sparc */
1080
1081 #endif /* __GNUC__ */
1082
1083 #endif /* not __m68k__ */
1084 \end{code}
1085
1086 %************************************************************************
1087 %*                                                                      *
1088 \subsubsection[StgMacros-array-primops]{Primitive arrays}
1089 %*                                                                      *
1090 %************************************************************************
1091
1092 We regularly use this macro to fish the ``contents'' part
1093 out of a DATA or TUPLE closure, which is what is used for
1094 non-ptr and ptr arrays (respectively).
1095
1096 BYTE_ARR_CTS returns a @C_ *@!
1097
1098 We {\em ASSUME} we can use the same macro for both!!
1099 \begin{code}
1100
1101 #ifdef DEBUG
1102 #define BYTE_ARR_CTS(a)                                 \
1103  ({ ASSERT(INFO_PTR(a) == (W_) ArrayOfData_info);       \
1104     ((C_ *) (((StgPtr) (a))+DATA_HS)); })
1105 #define PTRS_ARR_CTS(a)                                 \
1106  ({ ASSERT((INFO_PTR(a) == (W_) ArrayOfPtrs_info)       \
1107         || (INFO_PTR(a) == (W_) ImMutArrayOfPtrs_info));\
1108     ((a)+MUTUPLE_HS);} )
1109 #else
1110 #define BYTE_ARR_CTS(a)         ((char *) (((StgPtr) (a))+DATA_HS))
1111 #define PTRS_ARR_CTS(a)         ((a)+MUTUPLE_HS)
1112 #endif
1113
1114 /* sigh */
1115 extern I_ genSymZh(STG_NO_ARGS);
1116 extern I_ resetGenSymZh(STG_NO_ARGS);
1117 extern I_ incSeqWorldZh(STG_NO_ARGS);
1118
1119 extern I_ byteArrayHasNUL__ PROTO((const char *, I_));
1120 \end{code}
1121
1122 OK, the easy ops first: (all except \tr{newArr*}:
1123
1124 (OLD:) VERY IMPORTANT! The read/write/index primitive ops
1125 on @ByteArray#@s index the array using a {\em BYTE} offset, even
1126 if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
1127 This is because you might be trying to take apart a C struct, where
1128 the offset from the start of the struct isn't a multiple of the
1129 size of the thing you're getting.  Hence the @(char *)@ casts.
1130
1131 EVEN MORE IMPORTANT! The above is a lie.  The offsets for BlahArrays
1132 are in Blahs.  WDP 95/08
1133
1134 In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
1135 we cast to @P_@, because you can't index off an uncast \tr{void *}.
1136
1137 In the case of @Array#@ (which contain pointers), the offset is in units
1138 of one ptr (not bytes).
1139
1140 \begin{code}
1141 #define sameMutableArrayZh(r,a,b)       r=(I_)((a)==(b))
1142 #define sameMutableByteArrayZh(r,a,b)   r=(I_)((B_)(a)==(B_)(b))
1143
1144 #define readArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1145
1146 #define readCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1147 #define readIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1148 #define readAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1149 #define readFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1150 #define readDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1151
1152 /* result ("r") arg ignored in write macros! */
1153 #define writeArrayZh(a,i,v)     ((PP_) PTRS_ARR_CTS(a))[(i)]=(v)
1154
1155 #define writeCharArrayZh(a,i,v)   ((C_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1156 #define writeIntArrayZh(a,i,v)    ((I_ *)(BYTE_ARR_CTS(a)))[i] = (v)
1157 #define writeAddrArrayZh(a,i,v)   ((PP_)(BYTE_ARR_CTS(a)))[i] = (v)
1158 #define writeFloatArrayZh(a,i,v)  \
1159         ASSIGN_FLT((P_) (((StgFloat *)(BYTE_ARR_CTS(a))) + i),v)
1160 #define writeDoubleArrayZh(a,i,v) \
1161         ASSIGN_DBL((P_) (((StgDouble *)(BYTE_ARR_CTS(a))) + i),v)
1162
1163 #define indexArrayZh(r,a,i)       r=((PP_) PTRS_ARR_CTS(a))[(i)]
1164
1165 #define indexCharArrayZh(r,a,i)   indexCharOffAddrZh(r,BYTE_ARR_CTS(a),i)
1166 #define indexIntArrayZh(r,a,i)    indexIntOffAddrZh(r,BYTE_ARR_CTS(a),i)
1167 #define indexAddrArrayZh(r,a,i)   indexAddrOffAddrZh(r,BYTE_ARR_CTS(a),i)
1168 #define indexFloatArrayZh(r,a,i)  indexFloatOffAddrZh(r,BYTE_ARR_CTS(a),i)
1169 #define indexDoubleArrayZh(r,a,i) indexDoubleOffAddrZh(r,BYTE_ARR_CTS(a),i)
1170
1171 #define indexCharOffForeignObjZh(r,fo,i)   indexCharOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1172 #define indexIntOffForeignObjZh(r,fo,i)    indexIntOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1173 #define indexAddrOffForeignObjZh(r,fo,i)   indexAddrOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1174 #define indexFloatOffForeignObjZh(r,fo,i)  indexFloatOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1175 #define indexDoubleOffForeignObjZh(r,fo,i) indexDoubleOffAddrZh(r,ForeignObj_CLOSURE_DATA(fo),i)
1176
1177 #define indexCharOffAddrZh(r,a,i)   r= ((C_ *)(a))[i]
1178 #define indexIntOffAddrZh(r,a,i)    r= ((I_ *)(a))[i]
1179 #define indexAddrOffAddrZh(r,a,i)   r= ((PP_)(a))[i]
1180 #define indexFloatOffAddrZh(r,a,i)  r= PK_FLT((P_) (((StgFloat *)(a)) + i))
1181 #define indexDoubleOffAddrZh(r,a,i) r= PK_DBL((P_) (((StgDouble *)(a)) + i))
1182
1183 /* Freezing arrays-of-ptrs requires changing an info table, for the
1184    benefit of the generational collector.  It needs to scavenge mutable
1185    objects, even if they are in old space.  When they become immutable,
1186    they can be removed from this scavenge list.  */
1187 #define unsafeFreezeArrayZh(r,a)                                \
1188         do {                                            \
1189         P_ result;                                      \
1190         result=(P_) (a);                                \
1191         FREEZE_MUT_HDR(result,ImMutArrayOfPtrs_info);   \
1192         r = result;                                     \
1193         }while(0)
1194
1195 #define unsafeFreezeByteArrayZh(r,a)    r=(B_)(a)
1196 \end{code}
1197
1198 Now the \tr{newArr*} ops:
1199
1200 \begin{code}
1201 /*
1202 --------------------
1203 Will: ToDo: we need to find suitable places to put this comment, and the
1204 "in-general" one which follows.
1205
1206 ************ Nota Bene.  The "n" in this macro is guaranteed to
1207 be a register, *not* (say) Node[1].  That means that it is guaranteed
1208 to survive GC, provided only that the register is kept unaltered.
1209 This is important, because "n" is used after the HEAP_CHK.
1210
1211 In general, *all* parameters to these primitive-op macros are always
1212 registers.  (Will: For exactly *which* primitive-op macros is this guaranteed?
1213 Exactly those which can trigger GC?)
1214 ------------------------
1215
1216 NOTE: the above may now be OLD (WDP 94/02/10)
1217 */
1218 \end{code}
1219
1220 For char arrays, the size is in {\em BYTES}.
1221
1222 \begin{code}
1223 #define newCharArrayZh(r,liveness,n)    newByteArray(r,liveness,(n) * sizeof(C_))
1224 #define newIntArrayZh(r,liveness,n)     newByteArray(r,liveness,(n) * sizeof(I_))
1225 #define newAddrArrayZh(r,liveness,n)    newByteArray(r,liveness,(n) * sizeof(P_))
1226 #define newFloatArrayZh(r,liveness,n)   newByteArray(r,liveness,(n) * sizeof(StgFloat))
1227 #define newDoubleArrayZh(r,liveness,n)  newByteArray(r,liveness,(n) * sizeof(StgDouble))
1228
1229 #define newByteArray(r,liveness,n)                              \
1230 {                                                               \
1231   P_ result;                                                    \
1232   I_ size;                                                      \
1233                                                                 \
1234   HEAP_CHK(liveness,DATA_HS+BYTES_TO_STGWORDS(n),0);            \
1235   size = BYTES_TO_STGWORDS(n);                                  \
1236   ALLOC_PRIM(DATA_HS,size,0,DATA_HS+size) /* ticky ticky */;    \
1237   CC_ALLOC(CCC,DATA_HS+size,ARR_K);                             \
1238                                                                 \
1239   result = Hp-(DATA_HS+size)+1;                                 \
1240   SET_DATA_HDR(result,ArrayOfData_info,CCC,DATA_VHS+size,0);    \
1241   r = (B_) result;                                              \
1242 }
1243 \end{code}
1244
1245 Arrays of pointers need to be initialised; uses \tr{TUPLES}!
1246 The initialisation value is guaranteed to be in a register,
1247 and will be indicated by the liveness mask, so it's ok to do
1248 a \tr{HEAP_CHK}, which may trigger GC.
1249
1250 \begin{code}
1251 /* The new array initialization routine for the NCG */
1252 void newArrZh_init PROTO((P_ result, I_ n, P_ init));
1253
1254 #define newArrayZh(r,liveness,n,init)                   \
1255 {                                                       \
1256   P_ p;                                                 \
1257   P_ result;                                            \
1258                                                         \
1259   HEAP_CHK(liveness, MUTUPLE_HS+(n),0);                 \
1260   ALLOC_PRIM(MUTUPLE_HS,(n),0,MUTUPLE_HS+(n)) /* ticky ticky */; \
1261   CC_ALLOC(CCC,MUTUPLE_HS+(n),ARR_K); /* cc prof */     \
1262                                                         \
1263   result = Hp + 1 - (MUTUPLE_HS+(n));                   \
1264   SET_MUTUPLE_HDR(result,ArrayOfPtrs_info,CCC,MUTUPLE_VHS+(n),0) \
1265   for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
1266         *p = (W_) (init);                               \
1267   }                                                     \
1268                                                         \
1269   r = result;                                           \
1270 }
1271 \end{code}
1272
1273 %************************************************************************
1274 %*                                                                      *
1275 \subsubsection[StgMacros-SynchVar-primops]{Synchronizing Variables PrimOps}
1276 %*                                                                      *
1277 %************************************************************************
1278
1279 \begin{code}
1280 ED_(PrelBase_Z91Z93_closure);
1281
1282 #define newSynchVarZh(r, hp)                            \
1283 {                                                       \
1284   ALLOC_PRIM(MUTUPLE_HS,3,0,MUTUPLE_HS+3) /* ticky ticky */; \
1285   CC_ALLOC(CCC,MUTUPLE_HS+3,ARR_K); /* cc prof */       \
1286   SET_SVAR_HDR(hp,EmptySVar_info,CCC);                  \
1287   SVAR_HEAD(hp) = SVAR_TAIL(hp) = SVAR_VALUE(hp) = PrelBase_Z91Z93_closure;     \
1288   r = hp;                                               \
1289 }
1290 \end{code}
1291
1292 \begin{code}
1293 #ifdef CONCURRENT
1294
1295 void Yield PROTO((W_));
1296
1297 #define takeMVarZh(r, liveness, node)                   \
1298 {                                                       \
1299   while (INFO_PTR(node) != (W_) FullSVar_info) {        \
1300     if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure)             \
1301       SVAR_HEAD(node) = CurrentTSO;                     \
1302     else                                                \
1303       TSO_LINK(SVAR_TAIL(node)) = CurrentTSO;           \
1304     TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure;                \
1305     SVAR_TAIL(node) = CurrentTSO;                       \
1306     DO_YIELD(liveness << 1);                            \
1307   }                                                     \
1308   SET_INFO_PTR(node, EmptySVar_info);                   \
1309   r = SVAR_VALUE(node);                                 \
1310   SVAR_VALUE(node) = PrelBase_Z91Z93_closure;                           \
1311 }
1312
1313 #else
1314
1315 #define takeMVarZh(r, liveness, node)                   \
1316 {                                                       \
1317   if (INFO_PTR(node) != (W_) FullSVar_info) {           \
1318     /* Don't wrap the calls; we're done with STG land */\
1319     fflush(stdout);                                     \
1320     fprintf(stderr, "takeMVar#: MVar is empty.\n");     \
1321     EXIT(EXIT_FAILURE);                                 \
1322   }                                                     \
1323   SET_INFO_PTR(node, EmptySVar_info);                   \
1324   r = SVAR_VALUE(node);                                 \
1325   SVAR_VALUE(node) = PrelBase_Z91Z93_closure;                           \
1326 }
1327
1328 #endif
1329 \end{code}
1330
1331 \begin{code}
1332 #ifdef CONCURRENT
1333
1334 #ifdef GRAN
1335
1336 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1337 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1338 /* the CurrentProc. This means we have an implicit context switch after */
1339 /* putMVar even if unfair scheduling is used in GranSim (default)!  -- HWL */
1340
1341 #define putMVarZh(node, value)                          \
1342 {                                                       \
1343   P_ tso;                                               \
1344   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1345     /* Don't wrap the calls; we're done with STG land */\
1346     fflush(stdout);                                     \
1347     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1348     EXIT(EXIT_FAILURE);                                 \
1349   }                                                     \
1350   SET_INFO_PTR(node, FullSVar_info);                    \
1351   SVAR_VALUE(node) = value;                             \
1352   tso = SVAR_HEAD(node);                                \
1353   if (tso != (P_) PrelBase_Z91Z93_closure) {                            \
1354     if (DO_QP_PROF)                                     \
1355       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1356     if (ThreadQueueHd == PrelBase_Z91Z93_closure)               \
1357       ThreadQueueHd = tso;                      \
1358     else                                                \
1359       TSO_LINK(ThreadQueueTl) = tso;            \
1360     ThreadQueueTl = tso;                                \
1361     SVAR_HEAD(node) = TSO_LINK(tso);                    \
1362     TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure;                       \
1363     if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure)                 \
1364       SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure;           \
1365   }                                                     \
1366 }
1367
1368 #else /* !GRAN */
1369
1370 #define putMVarZh(node, value)                          \
1371 {                                                       \
1372   P_ tso;                                               \
1373   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1374     /* Don't wrap the calls; we're done with STG land */\
1375     fflush(stdout);                                     \
1376     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1377     EXIT(EXIT_FAILURE);                                 \
1378   }                                                     \
1379   SET_INFO_PTR(node, FullSVar_info);                    \
1380   SVAR_VALUE(node) = value;                             \
1381   tso = SVAR_HEAD(node);                                \
1382   if (tso != (P_) PrelBase_Z91Z93_closure) {                            \
1383     if (DO_QP_PROF)                                     \
1384       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1385     if (RunnableThreadsHd == PrelBase_Z91Z93_closure)                   \
1386       RunnableThreadsHd = tso;                          \
1387     else                                                \
1388       TSO_LINK(RunnableThreadsTl) = tso;                \
1389     RunnableThreadsTl = tso;                            \
1390     SVAR_HEAD(node) = TSO_LINK(tso);                    \
1391     TSO_LINK(tso) = (P_) PrelBase_Z91Z93_closure;                       \
1392     if(SVAR_HEAD(node) == (P_) PrelBase_Z91Z93_closure)                 \
1393       SVAR_TAIL(node) = (P_) PrelBase_Z91Z93_closure;           \
1394   }                                                     \
1395 }
1396
1397 #endif  /* GRAN */
1398
1399 #else
1400
1401 #define putMVarZh(node, value)                          \
1402 {                                                       \
1403   P_ tso;                                               \
1404   if (INFO_PTR(node) == (W_) FullSVar_info) {           \
1405     /* Don't wrap the calls; we're done with STG land */\
1406     fflush(stdout);                                     \
1407     fprintf(stderr, "putMVar#: MVar already full.\n");  \
1408     EXIT(EXIT_FAILURE);                                 \
1409   }                                                     \
1410   SET_INFO_PTR(node, FullSVar_info);                    \
1411   SVAR_VALUE(node) = value;                             \
1412 }
1413
1414 #endif
1415 \end{code}
1416
1417 \begin{code}
1418 #ifdef CONCURRENT
1419
1420 #define readIVarZh(r, liveness, node)                   \
1421 {                                                       \
1422   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1423     if (SVAR_HEAD(node) == PrelBase_Z91Z93_closure)             \
1424       SVAR_HEAD(node) = CurrentTSO;                     \
1425     else                                                \
1426       TSO_LINK(SVAR_TAIL(node)) = CurrentTSO;           \
1427     TSO_LINK(CurrentTSO) = (P_) PrelBase_Z91Z93_closure;                \
1428     SVAR_TAIL(node) = CurrentTSO;                       \
1429     DO_YIELD(liveness << 1);                            \
1430   }                                                     \
1431   r = SVAR_VALUE(node);                                 \
1432 }
1433
1434 #else
1435
1436 #define readIVarZh(r, liveness, node)                   \
1437 {                                                       \
1438   if (INFO_PTR(node) != (W_) ImMutArrayOfPtrs_info) {   \
1439     /* Don't wrap the calls; we're done with STG land */\
1440     fflush(stdout);                                     \
1441     fprintf(stderr, "readIVar#: IVar is empty.\n");     \
1442     EXIT(EXIT_FAILURE);                                 \
1443   }                                                     \
1444   r = SVAR_VALUE(node);                                 \
1445 }
1446
1447 #endif
1448 \end{code}
1449
1450 \begin{code}
1451 #ifdef CONCURRENT
1452
1453 #ifdef GRAN
1454
1455 /* Only difference to the !GRAN def: RunnableThreadsHd has been replaced by */
1456 /* ThreadQueueHd i.e. the tso is added at the end of the thread queue on */
1457 /* the CurrentProc. This means we have an implicit context switch after */
1458 /* writeIVar even if unfair scheduling is used in GranSim (default)!  -- HWL */
1459
1460 #define writeIVarZh(node, value)                        \
1461 {                                                       \
1462   P_ tso;                                               \
1463   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1464     /* Don't wrap the calls; we're done with STG land */\
1465     fflush(stdout);                                     \
1466     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1467     EXIT(EXIT_FAILURE);                                 \
1468   }                                                     \
1469   tso = SVAR_HEAD(node);                                \
1470   if (tso != (P_) PrelBase_Z91Z93_closure) {                            \
1471     if (ThreadQueueHd == PrelBase_Z91Z93_closure)               \
1472       ThreadQueueHd = tso;                      \
1473     else                                                \
1474       TSO_LINK(ThreadQueueTl) = tso;            \
1475     while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) {                   \
1476       if (DO_QP_PROF)                                   \
1477         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1478       tso = TSO_LINK(tso);                              \
1479     }                                                   \
1480     if (DO_QP_PROF)                                     \
1481       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1482     ThreadQueueTl = tso;                                \
1483   }                                                     \
1484   /* Don't use freeze, since it's conditional on GC */  \
1485   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1486   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1487   SVAR_VALUE(node) = value;                             \
1488 }
1489
1490 #else /* !GRAN */
1491
1492 #define writeIVarZh(node, value)                        \
1493 {                                                       \
1494   P_ tso;                                               \
1495   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1496     /* Don't wrap the calls; we're done with STG land */\
1497     fflush(stdout);                                     \
1498     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1499     EXIT(EXIT_FAILURE);                                 \
1500   }                                                     \
1501   tso = SVAR_HEAD(node);                                \
1502   if (tso != (P_) PrelBase_Z91Z93_closure) {                            \
1503     if (RunnableThreadsHd == PrelBase_Z91Z93_closure)                   \
1504       RunnableThreadsHd = tso;                          \
1505     else                                                \
1506       TSO_LINK(RunnableThreadsTl) = tso;                \
1507     while(TSO_LINK(tso) != PrelBase_Z91Z93_closure) {                   \
1508       if (DO_QP_PROF)                                   \
1509         STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);  \
1510       tso = TSO_LINK(tso);                              \
1511     }                                                   \
1512     if (DO_QP_PROF)                                     \
1513       STGCALL3(void,(void *, char *, P_, P_),QP_Event2,do_qp_prof > 1 ? "RA" : "RG",tso,CurrentTSO);    \
1514     RunnableThreadsTl = tso;                            \
1515   }                                                     \
1516   /* Don't use freeze, since it's conditional on GC */  \
1517   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1518   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1519   SVAR_VALUE(node) = value;                             \
1520 }
1521
1522 #endif  /* GRAN */
1523
1524 #else
1525
1526 #define writeIVarZh(node, value)                        \
1527 {                                                       \
1528   P_ tso;                                               \
1529   if (INFO_PTR(node) == (W_) ImMutArrayOfPtrs_info) {   \
1530     /* Don't wrap the calls; we're done with STG land */\
1531     fflush(stdout);                                     \
1532     fprintf(stderr, "writeIVar#: IVar already full.\n");\
1533     EXIT(EXIT_FAILURE);                                 \
1534   }                                                     \
1535   /* Don't use freeze, since it's conditional on GC */  \
1536   SET_INFO_PTR(node, ImMutArrayOfPtrs_info);            \
1537   MUTUPLE_CLOSURE_SIZE(node) = (MUTUPLE_VHS+1);         \
1538   SVAR_VALUE(node) = value;                             \
1539 }
1540
1541 #endif
1542 \end{code}
1543
1544 %************************************************************************
1545 %*                                                                      *
1546 \subsubsection[StgMacros-Wait-primops]{Delay/Wait PrimOps}
1547 %*                                                                      *
1548 %************************************************************************
1549
1550 \begin{code}
1551 #ifdef CONCURRENT
1552
1553 /* ToDo: for GRAN */
1554
1555 #define delayZh(liveness, us)                           \
1556   {                                                     \
1557     if (WaitingThreadsTl == PrelBase_Z91Z93_closure)            \
1558       WaitingThreadsHd = CurrentTSO;                    \
1559     else                                                \
1560       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1561     WaitingThreadsTl = CurrentTSO;                      \
1562     TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;                     \
1563     TSO_EVENT(CurrentTSO) = (W_) ((us) < 1 ? 1 : (us)); \
1564     DO_YIELD(liveness << 1);                            \
1565   }
1566
1567 #else
1568
1569 #define delayZh(liveness, us)                           \
1570   {                                                     \
1571     fflush(stdout);                                     \
1572     fprintf(stderr, "delay#: unthreaded build.\n");     \
1573     EXIT(EXIT_FAILURE);                                 \
1574   }
1575
1576 #endif
1577
1578 #ifdef CONCURRENT
1579
1580 /* ToDo: something for GRAN */
1581
1582 #define waitReadZh(liveness, fd)                        \
1583   {                                                     \
1584     if (WaitingThreadsTl == PrelBase_Z91Z93_closure)            \
1585       WaitingThreadsHd = CurrentTSO;                    \
1586     else                                                \
1587       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1588     WaitingThreadsTl = CurrentTSO;                      \
1589     TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;                     \
1590     TSO_EVENT(CurrentTSO) = (W_) (-(fd));               \
1591     DO_YIELD(liveness << 1);                            \
1592   }
1593
1594 #else
1595
1596 #define waitReadZh(liveness, fd)                        \
1597   {                                                     \
1598     fflush(stdout);                                     \
1599     fprintf(stderr, "waitRead#: unthreaded build.\n");  \
1600     EXIT(EXIT_FAILURE);                                 \
1601   }
1602
1603 #endif
1604
1605 #ifdef CONCURRENT
1606
1607 /* ToDo: something for GRAN */
1608
1609 #ifdef HAVE_SYS_TYPES_H
1610 #include <sys/types.h>
1611 #endif  HAVE_SYS_TYPES_H */
1612
1613 #define waitWriteZh(liveness, fd)                       \
1614   {                                                     \
1615     if (WaitingThreadsTl == PrelBase_Z91Z93_closure)            \
1616       WaitingThreadsHd = CurrentTSO;                    \
1617     else                                                \
1618       TSO_LINK(WaitingThreadsTl) = CurrentTSO;          \
1619     WaitingThreadsTl = CurrentTSO;                      \
1620     TSO_LINK(CurrentTSO) = PrelBase_Z91Z93_closure;                     \
1621     TSO_EVENT(CurrentTSO) = (W_) (-(fd+FD_SETSIZE));    \
1622     DO_YIELD(liveness << 1);                            \
1623   }
1624
1625 #else
1626
1627 #define waitWriteZh(liveness, fd)                       \
1628   {                                                     \
1629     fflush(stdout);                                     \
1630     fprintf(stderr, "waitWrite#: unthreaded build.\n"); \
1631     EXIT(EXIT_FAILURE);                                 \
1632   }
1633
1634 #endif
1635
1636 \end{code}
1637
1638 %************************************************************************
1639 %*                                                                      *
1640 \subsubsection[StgMacros-IO-primops]{Primitive I/O, error-handling primops}
1641 %*                                                                      *
1642 %************************************************************************
1643
1644 \begin{code}
1645 extern P_ TopClosure;
1646 EXTFUN(ErrorIO_innards);
1647 EXTFUN(__std_entry_error__);
1648
1649 #define errorIOZh(a)            \
1650     do { TopClosure=(a);        \
1651          (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stdout); \
1652          (void) SAFESTGCALL1(I_,(void *, FILE *),fflush,stderr); \
1653          JMP_(ErrorIO_innards); \
1654     } while(0)
1655
1656 #if !defined(CALLER_SAVES_SYSTEM)
1657 /* can use the macros */
1658 #define stg_getc(stream)        getc((FILE *) (stream))
1659 #define stg_putc(c,stream)      putc((c),((FILE *) (stream)))
1660 #else
1661 /* must not use the macros (they contain embedded calls to _filbuf/whatnot) */
1662 #define stg_getc(stream)        SAFESTGCALL1(I_,(void *, FILE *),fgetc,(FILE *) (stream))
1663 #define stg_putc(c,stream)      SAFESTGCALL2(I_,(void *, char, FILE *),fputc,(c),((FILE *) (stream)))
1664 #endif
1665
1666 int initialize_virtual_timer(int us);
1667 int install_segv_handler(STG_NO_ARGS);
1668 int install_vtalrm_handler(STG_NO_ARGS);
1669 void initUserSignals(STG_NO_ARGS);
1670 void blockUserSignals(STG_NO_ARGS);
1671 void unblockUserSignals(STG_NO_ARGS);
1672 IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
1673 IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
1674 IF_RTS(void AwaitEvent(I_ delta);)
1675
1676 #if  defined(_POSIX_SOURCE) && !defined(nextstep3_TARGET_OS)
1677         /* For nextstep3_TARGET_OS comment see stgdefs.h. CaS */
1678 extern I_ sig_install PROTO((I_, I_, sigset_t *));
1679 #define stg_sig_ignore(s,m)     SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN,(sigset_t *)m)
1680 #define stg_sig_default(s,m)    SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL,(sigset_t *)m)
1681 #define stg_sig_catch(s,sp,m)   SAFESTGCALL3(I_,(void *, I_, I_),sig_install,s,sp,(sigset_t *)m)
1682 #else
1683 extern I_ sig_install PROTO((I_, I_));
1684 #define stg_sig_ignore(s,m)     SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_IGN)
1685 #define stg_sig_default(s,m)    SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,STG_SIG_DFL)
1686 #define stg_sig_catch(s,sp,m)   SAFESTGCALL2(I_,(void *, I_, I_),sig_install,s,sp)
1687 #endif
1688
1689 #define STG_SIG_DFL     (-1)
1690 #define STG_SIG_IGN     (-2)
1691 #define STG_SIG_ERR     (-3)
1692
1693 StgInt getErrorHandler(STG_NO_ARGS);
1694 #ifndef PAR
1695 void   raiseError PROTO((StgStablePtr handler));
1696 StgInt catchError PROTO((StgStablePtr newErrorHandler));
1697 #endif
1698 void decrementErrorCount(STG_NO_ARGS);
1699
1700 #define stg_catchError(sp)        SAFESTGCALL1(I_,(void *, StgStablePtr),catchError,sp)
1701 #define stg_decrementErrorCount() SAFESTGCALL0(void,(void *),decrementErrorCount)
1702 \end{code}
1703
1704 %************************************************************************
1705 %*                                                                      *
1706 \subsubsection[StgMacros-stable-ptr]{Primitive ops for manipulating stable pointers}
1707 %*                                                                      *
1708 %************************************************************************
1709
1710
1711 The type of these should be:
1712
1713 \begin{verbatim}
1714 makeStablePointer#  :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
1715 deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
1716 \end{verbatim}
1717
1718 Since world-tokens are no longer explicitly passed around, the
1719 implementations have a few less arguments/results.
1720
1721 The simpler one is @deRefStablePointer#@ (which is only a primop
1722 because it is more polymorphic than is allowed of a ccall).
1723
1724 \begin{code}
1725 #ifdef PAR
1726
1727 #define deRefStablePtrZh(ri,sp)                                     \
1728 do {                                                                \
1729     fflush(stdout);                                                 \
1730     fprintf(stderr, "deRefStablePtr#: no stable pointer support.\n");\
1731     EXIT(EXIT_FAILURE);                                             \
1732 } while(0)
1733
1734 #else /* !PAR */
1735
1736 extern StgPtr _deRefStablePointer PROTO((StgInt, StgPtr));
1737
1738 #define deRefStablePtrZh(ri,sp) \
1739    ri = SAFESTGCALL2(I_,(void *, I_, P_),_deRefStablePointer,sp,StorageMgrInfo.StablePointerTable);
1740 \end{code}
1741
1742 Declarations for other stable pointer operations.
1743
1744 \begin{code}
1745 void    freeStablePointer       PROTO((I_ stablePtr));
1746
1747 void    enterStablePtr          PROTO((StgStablePtr, StgFunPtr));
1748 void    performIO               PROTO((StgStablePtr));
1749 I_      enterInt                PROTO((StgStablePtr));
1750 I_      enterFloat              PROTO((StgStablePtr));
1751 P_      deRefStablePointer      PROTO((StgStablePtr));
1752 IF_RTS(I_ catchSoftHeapOverflow PROTO((StgStablePtr, I_));)
1753 IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
1754 IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
1755 IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
1756
1757 EXTFUN(stopPerformIODirectReturn);
1758 EXTFUN(startPerformIO);
1759 EXTFUN(stopEnterIntDirectReturn);
1760 EXTFUN(startEnterInt);
1761 EXTFUN(stopEnterFloatDirectReturn);
1762 EXTFUN(startEnterFloat);
1763
1764 void enterStablePtr PROTO((StgStablePtr stableIndex, StgFunPtr startCode));
1765
1766 #endif /* !PAR */
1767
1768 IF_RTS(extern I_ ErrorIO_call_count;)
1769 \end{code}
1770
1771 Somewhat harder is @makeStablePointer#@ --- it is usually simple but
1772 if we're unlucky, it will have to allocate a new table and copy the
1773 old bit over.  Since we might, very occasionally, have to call the
1774 garbage collector, this has to be a macro... sigh!
1775
1776 NB @newSP@ is required because it is entirely possible that
1777 @stablePtr@ and @unstablePtr@ are aliases and so we can't do the
1778 assignment to @stablePtr@ until we've finished with @unstablePtr@.
1779
1780 Another obscure piece of coding is the recalculation of the size of
1781 the table.  We do this just in case Jim's threads decide they want to
1782 context switch---in which case any stack-allocated variables may get
1783 trashed.  (If only there was a special heap check which didn't
1784 consider context switching...)
1785
1786 \begin{code}
1787 #ifndef PAR
1788
1789 /* Calculate SP Table size from number of pointers */
1790 #define SPTSizeFromNoPtrs( newNP ) (DYN_VHS + 1 + 2 * (newNP))
1791
1792 /* Calculate number of pointers in new table from number in old table:
1793    any strictly increasing expression will do here */
1794 #define CalcNewNoSPtrs( i ) ((i)*2 + 100)
1795
1796 void enlargeSPTable PROTO((P_, P_));
1797
1798 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1799 do {                                                                \
1800   EXTDATA_RO(StablePointerTable_info);                              \
1801   EXTDATA(UnusedSP);                                                \
1802   StgStablePtr newSP;                                               \
1803                                                                     \
1804   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
1805     { /* Variables used before the heap check */                    \
1806       I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1807       I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs );                   \
1808       I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs );                  \
1809       HEAP_CHK(liveness, _FHS+NewSize, 0);                          \
1810     }                                                               \
1811     { /* Variables used after the heap check - same values */       \
1812       I_ OldNoPtrs = SPT_NoPTRS( StorageMgrInfo.StablePointerTable ); \
1813       I_ NewNoPtrs = CalcNewNoSPtrs( OldNoPtrs );                   \
1814       I_ NewSize = SPTSizeFromNoPtrs( NewNoPtrs );                  \
1815       P_ SPTable = Hp + 1 - (_FHS + NewSize);                       \
1816                                                                     \
1817       CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */             \
1818       SET_DYN_HDR(SPTable,StablePointerTable_info,CCC,NewSize,NewNoPtrs);\
1819       SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
1820       StorageMgrInfo.StablePointerTable = SPTable;                  \
1821     }                                                               \
1822   }                                                                 \
1823                                                                     \
1824   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);               \
1825   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
1826   CHECK_SPT_CLOSURE( StorageMgrInfo.StablePointerTable );           \
1827   stablePtr = newSP;                                                \
1828 } while (0)
1829
1830 #else
1831
1832 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)             \
1833 do {                                                                \
1834     fflush(stdout);                                                 \
1835     fprintf(stderr, "makeStablePtr#: no stable pointer support.\n");\
1836     EXIT(EXIT_FAILURE);                                             \
1837 } while(0)
1838
1839 #endif /* !PAR */
1840 \end{code}
1841
1842 %************************************************************************
1843 %*                                                                      *
1844 \subsubsection[StgMacros-unsafePointerEquality]{Primitive `op' for breaking referential transparency}
1845 %*                                                                      *
1846 %************************************************************************
1847
1848 The type of this is @reallyUnsafePtrEquality :: a -> a -> Int#@ so we
1849 can expect three parameters: the two arguments and a "register" to put
1850 the result into.
1851
1852 Message to Will: This primop breaks referential transparency so badly
1853 you might want to leave it out.  On the other hand, if you hide it
1854 away in an appropriate monad, it's perfectly safe. [ADR]
1855
1856 Note that this primop is non-deterministic: different results can be
1857 obtained depending on just what the garbage collector (and code
1858 optimiser??) has done.  However, we can guarantee that if two objects
1859 are pointer-equal, they have the same denotation --- the converse most
1860 certainly doesn't hold.
1861
1862 ToDo ADR: The degree of non-determinism could be greatly reduced by
1863 following indirections.
1864
1865 \begin{code}
1866 #define reallyUnsafePtrEqualityZh(r,a,b) r=((StgPtr)(a) == (StgPtr)(b))
1867 \end{code}
1868
1869 %************************************************************************
1870 %*                                                                      *
1871 \subsubsection[StgMacros-parallel-primop]{Primitive `op' for sparking (etc)}
1872 %*                                                                      *
1873 %************************************************************************
1874
1875 Assuming local sparking in some form, we can now inline the spark request.
1876
1877 We build a doubly-linked list in the heap, so that we can handle FIFO
1878 or LIFO scheduling as we please.
1879
1880 Anything with tag >= 0 is in WHNF, so we discard it.
1881
1882 \begin{code}
1883 #ifdef CONCURRENT
1884
1885 ED_(PrelBase_Z91Z93_closure);
1886 ED_(True_closure);
1887
1888 #if defined(GRAN)
1889 #define parZh(r,node)                           \
1890         PARZh(r,node,1,0,0,0,0,0)
1891
1892 #define parAtZh(r,node,where,identifier,gran_info,size_info,par_info,rest) \
1893         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,1)
1894
1895 #define parAtAbsZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1896         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,2)
1897
1898 #define parAtRelZh(r,node,proc,identifier,gran_info,size_info,par_info,rest) \
1899         parATZh(r,node,proc,identifier,gran_info,size_info,par_info,rest,3)
1900
1901 #define parAtForNowZh(r,node,where,identifier,gran_info,size_info,par_info,rest)        \
1902         parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,0)
1903
1904 #define parATZh(r,node,where,identifier,gran_info,size_info,par_info,rest,local)        \
1905 {                                                       \
1906   sparkq result;                                                \
1907   if (SHOULD_SPARK(node)) {                             \
1908     SaveAllStgRegs();                                   \
1909     { sparkq result;                                            \
1910       result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);        \
1911       if (local==2) {         /* special case for parAtAbs */   \
1912         GranSimSparkAtAbs(result,(I_)where,identifier);\
1913       } else if (local==3) {  /* special case for parAtRel */   \
1914         GranSimSparkAtAbs(result,(I_)(CurrentProc+where),identifier);   \
1915       } else {       \
1916         GranSimSparkAt(result,where,identifier);        \
1917       }        \
1918       context_switch = 1;                               \
1919     }                                                   \
1920     RestoreAllStgRegs();                                \
1921   } else if (do_qp_prof) {                              \
1922     I_ tid = threadId++;                                \
1923     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1924   }                                                     \
1925   r = 1; /* return code for successful spark -- HWL */  \
1926 }
1927
1928 #define parLocalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1929         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,1)
1930
1931 #define parGlobalZh(r,node,identifier,gran_info,size_info,par_info,rest) \
1932         PARZh(r,node,rest,identifier,gran_info,size_info,par_info,0)
1933
1934 #if 1
1935
1936 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1937 {                                                       \
1938   if (SHOULD_SPARK(node)) {                             \
1939     SaveAllStgRegs();                                   \
1940     { sparkq result;                                            \
1941       result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1942       add_to_spark_queue(result);                               \
1943       GranSimSpark(local,(P_)node);                                     \
1944       context_switch = 1;                               \
1945     }                                                   \
1946     RestoreAllStgRegs();                                \
1947   } else if (do_qp_prof) {                              \
1948     I_ tid = threadId++;                                \
1949     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1950   }                                                     \
1951   r = 1; /* return code for successful spark -- HWL */  \
1952 }
1953
1954 #else
1955
1956 #define PARZh(r,node,rest,identifier,gran_info,size_info,par_info,local) \
1957 {                                                       \
1958   sparkq result;                                                \
1959   if (SHOULD_SPARK(node)) {                             \
1960     result = NewSpark((P_)node,identifier,gran_info,size_info,par_info,local);\
1961     ADD_TO_SPARK_QUEUE(result);                         \
1962     SAFESTGCALL2(void,(W_),GranSimSpark,local,(P_)node);        \
1963     /* context_switch = 1;  not needed any more -- HWL */       \
1964   } else if (do_qp_prof) {                              \
1965     I_ tid = threadId++;                                \
1966     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
1967   }                                                     \
1968   r = 1; /* return code for successful spark -- HWL */  \
1969 }
1970
1971 #endif
1972
1973 #define copyableZh(r,node)                              \
1974   /* copyable not yet implemented!! */
1975
1976 #define noFollowZh(r,node)                              \
1977   /* noFollow not yet implemented!! */
1978
1979 #else  /* !GRAN */
1980
1981 extern I_ required_thread_count;
1982
1983 #ifdef PAR
1984 #define COUNT_SPARK     TSO_GLOBALSPARKS(CurrentTSO)++; sparksCreated++
1985 #else
1986 #define COUNT_SPARK
1987 #endif
1988
1989 /*
1990    Note that we must bump the required thread count NOW, rather
1991    than when the thread is actually created.
1992  */
1993
1994 #define forkZh(r,liveness,node)                         \
1995 {                                                       \
1996   while (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL]) \
1997     DO_YIELD((liveness << 1) | 1);                      \
1998   COUNT_SPARK;                                          \
1999   if (SHOULD_SPARK(node)) {                             \
2000     *PendingSparksTl[REQUIRED_POOL]++ = (P_)(node);     \
2001   } else if (DO_QP_PROF) {                              \
2002     I_ tid = threadId++;                                \
2003     SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);     \
2004   }                                                     \
2005   required_thread_count++;                              \
2006   context_switch = 1;                                   \
2007   r = 1; /* Should not be necessary */                  \
2008 }
2009
2010 #define parZh(r,node)                                   \
2011 {                                                       \
2012   COUNT_SPARK;                                          \
2013   if (SHOULD_SPARK(node) &&                             \
2014    PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) {  \
2015     *PendingSparksTl[ADVISORY_POOL]++ = (P_)(node);     \
2016   } else {                                              \
2017     sparksIgnored++;                                    \
2018     if (DO_QP_PROF) {                                   \
2019       I_ tid = threadId++;                              \
2020       SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node);   \
2021     }                                                   \
2022   }                                                     \
2023   r = 1; /* Should not be necessary */                  \
2024 }
2025
2026 #endif  /* GRAN */
2027
2028 #endif  /* CONCURRENT */
2029 \end{code}
2030
2031 The following seq# code should only be used in unoptimized code.
2032 Be warned: it's a potential bug-farm.
2033
2034 First we push two words on the B stack: the current value of RetReg
2035 (which may or may not be live), and a continuation snatched largely out
2036 of thin air (it's a point within this code block).  Then we set RetReg
2037 to the special polymorphic return code for seq, load up Node with the
2038 closure to be evaluated, and we're off.  When the eval returns to the
2039 polymorphic seq return point, the two words are popped off the B stack,
2040 RetReg is restored, and we jump to the continuation, completing the
2041 primop and going on our merry way.
2042
2043 \begin{code}
2044
2045 ED_RO_(vtbl_seq);
2046
2047 #define seqZh(r,liveness,node)              \
2048   ({                                        \
2049     __label__ cont;                         \
2050     /* STK_CHK(liveness,0,2,0,0,0,0); */    \
2051     /* SpB -= BREL(2); */                   \
2052     SpB[BREL(0)] = (W_) RetReg;             \
2053     SpB[BREL(1)] = (W_) &&cont;             \
2054     RetReg = (StgRetAddr) vtbl_seq;         \
2055     Node = node;                            \
2056     ENT_VIA_NODE();                         \
2057     InfoPtr = (D_)(INFO_PTR(Node));         \
2058     JMP_(ENTRY_CODE(InfoPtr));              \
2059     cont:                                   \
2060     r = 1; /* Should be unnecessary */      \
2061   })
2062
2063 \end{code}
2064
2065 %************************************************************************
2066 %*                                                                      *
2067 \subsubsection[StgMacros-foreign-objects]{Foreign Objects}
2068 %*                                                                      *
2069 %************************************************************************
2070
2071 [Based on previous MallocPtr comments -- SOF]
2072
2073 This macro is used to construct a ForeignObj on the heap.
2074
2075 What this does is plug the pointer (which will be in a local
2076 variable) together with its finalising/free routine, into a fresh heap
2077 object and then sets a result (which will be a register) to point
2078 to the fresh heap object.
2079
2080 To accommodate per-object finalisation, augment the macro with a
2081 finalisation routine argument. Nothing spectacular, just plug the
2082 pointer to the routine into the ForeignObj -- SOF 4/96
2083
2084 Question: what's this "SET_ACTIVITY" stuff - should I be doing this
2085 too?  (It's if you want to use the SPAT profiling tools to
2086 characterize program behavior by ``activity'' -- tail-calling,
2087 heap-checking, etc. -- see Ticky.lh.  It is quite specialized.
2088 WDP 95/1)
2089
2090 (Swapped first two arguments to make it come into line with what appears
2091 to be `standard' format, return register then liveness mask. -- SOF 4/96)
2092
2093 \begin{code}
2094 #ifndef PAR
2095
2096 StgInt eqForeignObj PROTO((StgForeignObj p1, StgForeignObj p2));
2097
2098 #define makeForeignObjZh(r, liveness, mptr, finalise)    \
2099 do {                                                     \
2100   P_ result;                                             \
2101                                                          \
2102   HEAP_CHK((W_)liveness, _FHS + ForeignObj_SIZE,0);              \
2103   CC_ALLOC(CCC,_FHS + ForeignObj_SIZE,ForeignObj_K); /* cc prof */   \
2104                                                                    \
2105   result = Hp + 1 - (_FHS + ForeignObj_SIZE);                      \
2106   SET_ForeignObj_HDR(result,ForeignObj_info,CCC,_FHS + ForeignObj_SIZE,0); \
2107   ForeignObj_CLOSURE_DATA(result)      = (P_)mptr;                 \
2108   ForeignObj_CLOSURE_FINALISER(result) = (P_)finalise;             \
2109   ForeignObj_CLOSURE_LINK(result) = StorageMgrInfo.ForeignObjList; \
2110   StorageMgrInfo.ForeignObjList = result;                          \
2111                                                         \
2112                                                         \
2113  /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n",       \
2114       result,                                           \
2115       result[0],result[1],                              \
2116       result[2],result[3]);*/                           \
2117                                                         \
2118   CHECK_ForeignObj_CLOSURE( result );                   \
2119   VALIDATE_ForeignObjList( StorageMgrInfo.ForeignObjList ); \
2120                                                         \
2121   (r) = (P_) result;                                    \
2122 } while (0)
2123
2124 #define writeForeignObjZh(res,datum)    ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum)
2125
2126 #else
2127 #define makeForeignObjZh(r, liveness, mptr, finalise)               \
2128 do {                                                                \
2129     fflush(stdout);                                                 \
2130     fprintf(stderr, "makeForeignObj#: no foreign object support.\n");\
2131     EXIT(EXIT_FAILURE);                                             \
2132 } while(0)
2133
2134 #define writeForeignObjZh(res,datum)    \
2135 do {                                                                \
2136     fflush(stdout);                                                 \
2137     fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\
2138     EXIT(EXIT_FAILURE);                                             \
2139 } while(0)
2140
2141 #endif /* !PAR */
2142 \end{code}
2143
2144
2145 End-of-file's multi-slurp protection:
2146 \begin{code}
2147 #endif /* ! STGMACROS_H */
2148 \end{code}