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