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