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