ghc/includes/StgMacros.lh

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