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