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