ghc/includes/StgMacros.h

   1 /* -----------------------------------------------------------------------------
   2  * $Id: StgMacros.h,v 1.57 2003/11/12 17:27:04 sof Exp $
   3  *
   4  * (c) The GHC Team, 1998-1999
   5  *
   6  * Macros used for writing STG-ish C code.
   7  *
   8  * ---------------------------------------------------------------------------*/
   9
  10 #ifndef STGMACROS_H
  11 #define STGMACROS_H
  12
  13 /* -----------------------------------------------------------------------------
  14   The following macros create function headers.
  15
  16   Each basic block is represented by a C function with no arguments.
  17   We therefore always begin with either
  18
  19   extern F_ f(void)
  20
  21   or
  22
  23   static F_ f(void)
  24
  25   The macros can be used either to define the function itself, or to provide
  26   prototypes (by following with a ';').
  27
  28   Note: the various I*_ shorthands in the second block below are used to
  29   declare forward references to local symbols. These shorthands *have* to
  30   use the 'extern' type specifier and not 'static'. The reason for this is
  31   that 'static' declares a reference as being a static/local variable,
  32   and *not* as a forward reference to a static variable.
  33
  34   This might seem obvious, but it had me stumped as to why my info tables
  35   were suddenly all filled with 0s.
  36
  37     -- sof 1/99
  38
  39   --------------------------------------------------------------------------- */
  40
  41 #define STGFUN(f)       StgFunPtr f(void)
  42 #define EXTFUN(f)       extern StgFunPtr f(void)
  43 #define EXTFUN_RTS(f)   extern DLL_IMPORT_RTS StgFunPtr f(void)
  44 #define FN_(f)          F_ f(void)
  45 #define IF_(f)          static F_ f(void)
  46 #define EF_(f)          extern F_ f(void)
  47 #define EDF_(f)         extern DLLIMPORT F_ f(void)
  48
  49 #define EXTINFO_RTS     extern DLL_IMPORT_RTS const StgInfoTable
  50 #define ETI_RTS         extern DLL_IMPORT_RTS const StgThunkInfoTable
  51
  52 // Info tables as generated by the compiler are simply arrays of words.
  53 typedef StgWord StgWordArray[];
  54
  55 #define ED_             extern
  56 #define EDD_            extern DLLIMPORT
  57 #define ED_RO_          extern const
  58 #define ID_             static
  59 #define ID_RO_          static const
  60 #define EI_             extern StgWordArray
  61 #define ERI_            extern const StgRetInfoTable
  62 #define II_             static StgWordArray
  63 #define IRI_            static const StgRetInfoTable
  64 #define EC_             extern StgClosure
  65 #define EDC_            extern DLLIMPORT StgClosure
  66 #define IC_             static StgClosure
  67 #define ECP_(x)         extern const StgClosure *(x)[]
  68 #define EDCP_(x)        extern DLLIMPORT StgClosure *(x)[]
  69 #define ICP_(x)         static const StgClosure *(x)[]
  70
  71 /* -----------------------------------------------------------------------------
  72    Entering
  73
  74    It isn't safe to "enter" every closure.  Functions in particular
  75    have no entry code as such; their entry point contains the code to
  76    apply the function.
  77    -------------------------------------------------------------------------- */
  78
  79 #define ENTER()                                 \
  80  {                                              \
  81  again:                                         \
  82   switch (get_itbl(R1.cl)->type) {              \
  83   case IND:                                     \
  84   case IND_OLDGEN:                              \
  85   case IND_PERM:                                \
  86   case IND_OLDGEN_PERM:                         \
  87   case IND_STATIC:                              \
  88       R1.cl = ((StgInd *)R1.cl)->indirectee;    \
  89       goto again;                               \
  90   case BCO:                                     \
  91   case FUN:                                     \
  92   case FUN_1_0:                                 \
  93   case FUN_0_1:                                 \
  94   case FUN_2_0:                                 \
  95   case FUN_1_1:                                 \
  96   case FUN_0_2:                                 \
  97   case FUN_STATIC:                              \
  98   case PAP:                                     \
  99       JMP_(ENTRY_CODE(Sp[0]));                  \
 100   default:                                      \
 101       JMP_(GET_ENTRY(R1.cl));                   \
 102   }                                             \
 103  }
 104
 105 /* -----------------------------------------------------------------------------
 106    Heap/Stack Checks.
 107
 108    When failing a check, we save a return address on the stack and
 109    jump to a pre-compiled code fragment that saves the live registers
 110    and returns to the scheduler.
 111
 112    The return address in most cases will be the beginning of the basic
 113    block in which the check resides, since we need to perform the check
 114    again on re-entry because someone else might have stolen the resource
 115    in the meantime.
 116    ------------------------------------------------------------------------- */
 117
 118 #define STK_CHK_FUN(headroom,assts)             \
 119         if (Sp - headroom < SpLim) {            \
 120             assts                               \
 121             JMP_(stg_gc_fun);                   \
 122         }
 123
 124 #define HP_CHK_FUN(headroom,assts)                                      \
 125         DO_GRAN_ALLOCATE(headroom)                                      \
 126         if ((Hp += headroom) > HpLim) {                                 \
 127             HpAlloc = (headroom);                                       \
 128             assts                                                       \
 129             JMP_(stg_gc_fun);                                           \
 130         }
 131
 132 // When doing both a heap and a stack check, don't move the heap
 133 // pointer unless the stack check succeeds.  Otherwise we might end up
 134 // with slop at the end of the current block, which can confuse the
 135 // LDV profiler.
 136 #define HP_STK_CHK_FUN(stk_headroom,hp_headroom,assts)                  \
 137         DO_GRAN_ALLOCATE(hp_headroom)                                   \
 138         if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) { \
 139             HpAlloc = (hp_headroom);                                    \
 140             assts                                                       \
 141             JMP_(stg_gc_fun);                                           \
 142         }
 143
 144 /* -----------------------------------------------------------------------------
 145    A Heap Check in a case alternative are much simpler: everything is
 146    on the stack and covered by a liveness mask already, and there is
 147    even a return address with an SRT info table there as well.
 148
 149    Just push R1 and return to the scheduler saying 'EnterGHC'
 150
 151    {STK,HP,HP_STK}_CHK_NP are the various checking macros for
 152    bog-standard case alternatives, thunks, and non-top-level
 153    functions.  In all these cases, node points to a closure that we
 154    can just enter to restart the heap check (the NP stands for 'node points').
 155
 156    In the NP case GranSim absolutely has to check whether the current node
 157    resides on the current processor. Otherwise a FETCH event has to be
 158    scheduled. All that is done in GranSimFetch. -- HWL
 159
 160    HpLim points to the LAST WORD of valid allocation space.
 161    -------------------------------------------------------------------------- */
 162
 163 #define STK_CHK_NP(headroom,tag_assts)          \
 164         if ((Sp - (headroom)) < SpLim) {        \
 165             tag_assts                           \
 166             JMP_(stg_gc_enter_1);               \
 167         }
 168
 169 #define HP_CHK_NP(headroom,tag_assts)                                   \
 170         DO_GRAN_ALLOCATE(headroom)                                      \
 171         if ((Hp += (headroom)) > HpLim) {                               \
 172             HpAlloc = (headroom);                                       \
 173             tag_assts                                                   \
 174             JMP_(stg_gc_enter_1);                                       \
 175         }
 176
 177 // See comment on HP_STK_CHK_FUN above.
 178 #define HP_STK_CHK_NP(stk_headroom, hp_headroom, tag_assts) \
 179         DO_GRAN_ALLOCATE(hp_headroom)                              \
 180         if ((Sp - (stk_headroom)) < SpLim || (Hp += (hp_headroom)) > HpLim) { \
 181             HpAlloc = (hp_headroom);                            \
 182             tag_assts                                           \
 183             JMP_(stg_gc_enter_1);                               \
 184         }
 185
 186
 187 /* Heap checks for branches of a primitive case / unboxed tuple return */
 188
 189 #define GEN_HP_CHK_ALT(headroom,lbl,tag_assts)                  \
 190         DO_GRAN_ALLOCATE(headroom)                              \
 191         if ((Hp += (headroom)) > HpLim) {                       \
 192             HpAlloc = (headroom);                               \
 193             tag_assts                                           \
 194             JMP_(lbl);                                          \
 195         }
 196
 197 #define HP_CHK_NOREGS(headroom,tag_assts) \
 198     GEN_HP_CHK_ALT(headroom,stg_gc_noregs,tag_assts);
 199 #define HP_CHK_UNPT_R1(headroom,tag_assts)  \
 200     GEN_HP_CHK_ALT(headroom,stg_gc_unpt_r1,tag_assts);
 201 #define HP_CHK_UNBX_R1(headroom,tag_assts)  \
 202     GEN_HP_CHK_ALT(headroom,stg_gc_unbx_r1,tag_assts);
 203 #define HP_CHK_F1(headroom,tag_assts)       \
 204     GEN_HP_CHK_ALT(headroom,stg_gc_f1,tag_assts);
 205 #define HP_CHK_D1(headroom,tag_assts)       \
 206     GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
 207 #define HP_CHK_L1(headroom,tag_assts)       \
 208     GEN_HP_CHK_ALT(headroom,stg_gc_l1,tag_assts);
 209
 210 /* -----------------------------------------------------------------------------
 211    Generic Heap checks.
 212
 213    These are slow, but have the advantage of being usable in a variety
 214    of situations.
 215
 216    The one restriction is that any relevant SRTs must already be pointed
 217    to from the stack.  The return address doesn't need to have an info
 218    table attached: hence it can be any old code pointer.
 219
 220    The liveness mask is a logical 'XOR' of NO_PTRS and zero or more
 221    Rn_PTR constants defined below.  All registers will be saved, but
 222    the garbage collector needs to know which ones contain pointers.
 223
 224    Good places to use a generic heap check:
 225
 226         - case alternatives (the return address with an SRT is already
 227           on the stack).
 228
 229         - primitives (no SRT required).
 230
 231    The stack frame layout for a RET_DYN is like this:
 232
 233           some pointers         |-- GET_PTRS(liveness) words
 234           some nonpointers      |-- GET_NONPTRS(liveness) words
 235
 236           L1                    \
 237           D1-2                  |-- RET_DYN_NONPTR_REGS_SIZE words
 238           F1-4                  /
 239
 240           R1-8                  |-- RET_DYN_BITMAP_SIZE words
 241
 242           return address        \
 243           liveness mask         |-- StgRetDyn structure
 244           stg_gen_chk_info      /
 245
 246    we assume that the size of a double is always 2 pointers (wasting a
 247    word when it is only one pointer, but avoiding lots of #ifdefs).
 248
 249    NOTE: if you change the layout of RET_DYN stack frames, then you
 250    might also need to adjust the value of RESERVED_STACK_WORDS in
 251    Constants.h.
 252    -------------------------------------------------------------------------- */
 253
 254 // VERY MAGIC CONSTANTS!
 255 // must agree with code in HeapStackCheck.c, stg_gen_chk, and
 256 // RESERVED_STACK_WORDS in Constants.h.
 257 //
 258 #define RET_DYN_BITMAP_SIZE 8
 259 #define RET_DYN_NONPTR_REGS_SIZE 10
 260 #define ALL_NON_PTRS 0xff
 261
 262 // Sanity check that RESERVED_STACK_WORDS is reasonable.  We can't
 263 // just derive RESERVED_STACK_WORDS because it's used in Haskell code
 264 // too.
 265 #if RESERVED_STACK_WORDS != (3 + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE)
 266 #error RESERVED_STACK_WORDS may be wrong!
 267 #endif
 268
 269 #define LIVENESS_MASK(ptr_regs)  (ALL_NON_PTRS ^ (ptr_regs))
 270
 271 // We can have up to 255 pointers and 255 nonpointers in the stack
 272 // frame.
 273 #define N_NONPTRS(n)  ((n)<<16)
 274 #define N_PTRS(n)     ((n)<<24)
 275
 276 #define GET_NONPTRS(l) ((l)>>16 & 0xff)
 277 #define GET_PTRS(l)    ((l)>>24 & 0xff)
 278 #define GET_LIVENESS(l) ((l) & 0xffff)
 279
 280 #define NO_PTRS   0
 281 #define R1_PTR    1<<0
 282 #define R2_PTR    1<<1
 283 #define R3_PTR    1<<2
 284 #define R4_PTR    1<<3
 285 #define R5_PTR    1<<4
 286 #define R6_PTR    1<<5
 287 #define R7_PTR    1<<6
 288 #define R8_PTR    1<<7
 289
 290 #define HP_CHK_UNBX_TUPLE(headroom,liveness,code)       \
 291    if ((Hp += (headroom)) > HpLim ) {                   \
 292         HpAlloc = (headroom);                           \
 293         code                                            \
 294         R9.w = (W_)LIVENESS_MASK(liveness);             \
 295         JMP_(stg_gc_ut);                                \
 296     }
 297
 298 #define HP_CHK_GEN(headroom,liveness,reentry)                   \
 299    if ((Hp += (headroom)) > HpLim ) {                           \
 300         HpAlloc = (headroom);                                   \
 301         R9.w = (W_)LIVENESS_MASK(liveness);                     \
 302         R10.w = (W_)reentry;                                    \
 303         JMP_(stg_gc_gen);                                       \
 304     }
 305
 306 #define HP_CHK_GEN_TICKY(headroom,liveness,reentry)     \
 307    HP_CHK_GEN(headroom,liveness,reentry);               \
 308    TICK_ALLOC_HEAP_NOCTR(headroom)
 309
 310 #define STK_CHK_GEN(headroom,liveness,reentry)  \
 311    if ((Sp - (headroom)) < SpLim) {                             \
 312         R9.w = (W_)LIVENESS_MASK(liveness);                     \
 313         R10.w = (W_)reentry;                                    \
 314         JMP_(stg_gc_gen);                                       \
 315    }
 316
 317 #define MAYBE_GC(liveness,reentry)              \
 318    if (doYouWantToGC()) {                       \
 319         R9.w = (W_)LIVENESS_MASK(liveness);     \
 320         R10.w = (W_)reentry;                    \
 321         JMP_(stg_gc_gen_hp);                    \
 322    }
 323
 324 /* -----------------------------------------------------------------------------
 325    Voluntary Yields/Blocks
 326
 327    We only have a generic version of this at the moment - if it turns
 328    out to be slowing us down we can make specialised ones.
 329    -------------------------------------------------------------------------- */
 330
 331 EXTFUN_RTS(stg_gen_yield);
 332 EXTFUN_RTS(stg_gen_block);
 333
 334 #define YIELD(liveness,reentry)                 \
 335   {                                             \
 336    R9.w  = (W_)LIVENESS_MASK(liveness);         \
 337    R10.w = (W_)reentry;                         \
 338    JMP_(stg_gen_yield);                         \
 339   }
 340
 341 #define BLOCK(liveness,reentry)                 \
 342   {                                             \
 343    R9.w  = (W_)LIVENESS_MASK(liveness);         \
 344    R10.w = (W_)reentry;                         \
 345    JMP_(stg_gen_block);                         \
 346   }
 347
 348 #define BLOCK_NP(ptrs)                          \
 349   {                                             \
 350     EXTFUN_RTS(stg_block_##ptrs);                       \
 351     JMP_(stg_block_##ptrs);                     \
 352   }
 353
 354 #if defined(PAR)
 355 /*
 356   Similar to BLOCK_NP but separates the saving of the thread state from the
 357   actual jump via an StgReturn
 358 */
 359
 360 #define SAVE_THREAD_STATE(ptrs)                  \
 361   ASSERT(ptrs==1);                               \
 362   Sp -= 1;                                       \
 363   Sp[0] = R1.w;                                  \
 364   SaveThreadState();
 365
 366 #define THREAD_RETURN(ptrs)                      \
 367   ASSERT(ptrs==1);                               \
 368   CurrentTSO->what_next = ThreadEnterGHC;        \
 369   R1.i = ThreadBlocked;                          \
 370   JMP_(StgReturn);
 371 #endif
 372
 373 /* -----------------------------------------------------------------------------
 374    CCall_GC needs to push a dummy stack frame containing the contents
 375    of volatile registers and variables.
 376
 377    We use a RET_DYN frame the same as for a dynamic heap check.
 378    ------------------------------------------------------------------------- */
 379
 380 /* -----------------------------------------------------------------------------
 381    Vectored Returns
 382
 383    RETVEC(p,t) where 'p' is a pointer to the info table for a
 384    vectored return address, returns the address of the return code for
 385    tag 't'.
 386
 387    Return vectors are placed in *reverse order* immediately before the info
 388    table for the return address.  Hence the formula for computing the
 389    actual return address is (addr - sizeof(RetInfoTable) - tag - 1).
 390    The extra subtraction of one word is because tags start at zero.
 391    -------------------------------------------------------------------------- */
 392
 393 #ifdef TABLES_NEXT_TO_CODE
 394 #define RET_VEC(p,t) (*((P_)(p) - sizeofW(StgRetInfoTable) - t - 1))
 395 #else
 396 #define RET_VEC(p,t) (((StgRetInfoTable *)p)->vector[t])
 397 #endif
 398
 399 /* -----------------------------------------------------------------------------
 400    Misc
 401    -------------------------------------------------------------------------- */
 402
 403
 404 /* set the tag register (if we have one) */
 405 #define SET_TAG(t)  /* nothing */
 406
 407 #ifdef EAGER_BLACKHOLING
 408 #  ifdef SMP
 409 #    define UPD_BH_UPDATABLE(info)                              \
 410         TICK_UPD_BH_UPDATABLE();                                \
 411         {                                                       \
 412           bdescr *bd = Bdescr(R1.p);                            \
 413           if (bd->u.back != (bdescr *)BaseReg) {                \
 414              if (bd->gen_no >= 1 || bd->step->no >= 1) {        \
 415                  LOCK_THUNK(info);                              \
 416              } else {                                           \
 417                  EXTFUN_RTS(stg_gc_enter_1_hponly);             \
 418                  JMP_(stg_gc_enter_1_hponly);                   \
 419              }                                                  \
 420           }                                                     \
 421         }                                                       \
 422         SET_INFO(R1.cl,&stg_BLACKHOLE_info)
 423 #    define UPD_BH_SINGLE_ENTRY(info)                           \
 424         TICK_UPD_BH_SINGLE_ENTRY();                             \
 425         {                                                       \
 426           bdescr *bd = Bdescr(R1.p);                            \
 427           if (bd->u.back != (bdescr *)BaseReg) {                \
 428              if (bd->gen_no >= 1 || bd->step->no >= 1) {        \
 429                  LOCK_THUNK(info);                              \
 430              } else {                                           \
 431                  EXTFUN_RTS(stg_gc_enter_1_hponly);             \
 432                  JMP_(stg_gc_enter_1_hponly);                   \
 433              }                                                  \
 434           }                                                     \
 435         }                                                       \
 436         SET_INFO(R1.cl,&stg_BLACKHOLE_info)
 437 #  else
 438 #   ifndef PROFILING
 439 #    define UPD_BH_UPDATABLE(info)              \
 440         TICK_UPD_BH_UPDATABLE();                \
 441         SET_INFO(R1.cl,&stg_BLACKHOLE_info)
 442 #    define UPD_BH_SINGLE_ENTRY(info)           \
 443         TICK_UPD_BH_SINGLE_ENTRY();             \
 444         SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info)
 445 #   else
 446 // An object is replaced by a blackhole, so we fill the slop with zeros.
 447 //
 448 // This looks like it can't work - we're overwriting the contents of
 449 // the THUNK with slop!  Perhaps this never worked??? --SDM
 450 // The problem is that with eager-black-holing we currently perform
 451 // the black-holing operation at the *beginning* of the basic block,
 452 // when we still need the contents of the thunk.
 453 // Perhaps the thing to do is to overwrite it at the *end* of the
 454 // basic block, when we've already sucked out the thunk's contents? -- SLPJ
 455 //
 456 // Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
 457 //
 458 #    define UPD_BH_UPDATABLE(info)              \
 459         TICK_UPD_BH_UPDATABLE();                \
 460         LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl);               \
 461         SET_INFO(R1.cl,&stg_BLACKHOLE_info);    \
 462         LDV_recordCreate(R1.cl)
 463 #    define UPD_BH_SINGLE_ENTRY(info)           \
 464         TICK_UPD_BH_SINGLE_ENTRY();             \
 465         LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl);               \
 466         SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info)  \
 467         LDV_recordCreate(R1.cl)
 468 #   endif /* PROFILING */
 469 #  endif
 470 #else /* !EAGER_BLACKHOLING */
 471 #  define UPD_BH_UPDATABLE(thunk)    /* nothing */
 472 #  define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
 473 #endif /* EAGER_BLACKHOLING */
 474
 475 /* -----------------------------------------------------------------------------
 476    Moving Floats and Doubles
 477
 478    ASSIGN_FLT is for assigning a float to memory (usually the
 479               stack/heap).  The memory address is guaranteed to be
 480               StgWord aligned (currently == sizeof(void *)).
 481
 482    PK_FLT     is for pulling a float out of memory.  The memory is
 483               guaranteed to be StgWord aligned.
 484    -------------------------------------------------------------------------- */
 485
 486 INLINE_HEADER void        ASSIGN_FLT (W_ [], StgFloat);
 487 INLINE_HEADER StgFloat    PK_FLT     (W_ []);
 488
 489 #if ALIGNMENT_FLOAT <= ALIGNMENT_LONG
 490
 491 INLINE_HEADER void     ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
 492 INLINE_HEADER StgFloat PK_FLT    (W_ p_src[])                { return *(StgFloat *)p_src; }
 493
 494 #else  /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
 495
 496 INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
 497 {
 498     float_thing y;
 499     y.f = src;
 500     *p_dest = y.fu;
 501 }
 502
 503 INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
 504 {
 505     float_thing y;
 506     y.fu = *p_src;
 507     return(y.f);
 508 }
 509
 510 #endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */
 511
 512 #if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG
 513
 514 INLINE_HEADER void        ASSIGN_DBL (W_ [], StgDouble);
 515 INLINE_HEADER StgDouble   PK_DBL     (W_ []);
 516
 517 INLINE_HEADER void      ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
 518 INLINE_HEADER StgDouble PK_DBL    (W_ p_src[])                 { return *(StgDouble *)p_src; }
 519
 520 #else   /* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */
 521
 522 /* Sparc uses two floating point registers to hold a double.  We can
 523  * write ASSIGN_DBL and PK_DBL by directly accessing the registers
 524  * independently - unfortunately this code isn't writable in C, we
 525  * have to use inline assembler.
 526  */
 527 #if sparc_TARGET_ARCH
 528
 529 #define ASSIGN_DBL(dst0,src) \
 530     { StgPtr dst = (StgPtr)(dst0); \
 531       __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
 532         "=m" (((P_)(dst))[1]) : "f" (src)); \
 533     }
 534
 535 #define PK_DBL(src0) \
 536     ( { StgPtr src = (StgPtr)(src0); \
 537         register double d; \
 538       __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
 539         "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
 540     } )
 541
 542 #else /* ! sparc_TARGET_ARCH */
 543
 544 INLINE_HEADER void        ASSIGN_DBL (W_ [], StgDouble);
 545 INLINE_HEADER StgDouble   PK_DBL     (W_ []);
 546
 547 typedef struct
 548   { StgWord dhi;
 549     StgWord dlo;
 550   } unpacked_double;
 551
 552 typedef union
 553   { StgDouble d;
 554     unpacked_double du;
 555   } double_thing;
 556
 557 INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
 558 {
 559     double_thing y;
 560     y.d = src;
 561     p_dest[0] = y.du.dhi;
 562     p_dest[1] = y.du.dlo;
 563 }
 564
 565 /* GCC also works with this version, but it generates
 566    the same code as the previous one, and is not ANSI
 567
 568 #define ASSIGN_DBL( p_dest, src ) \
 569         *p_dest = ((double_thing) src).du.dhi; \
 570         *(p_dest+1) = ((double_thing) src).du.dlo \
 571 */
 572
 573 INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
 574 {
 575     double_thing y;
 576     y.du.dhi = p_src[0];
 577     y.du.dlo = p_src[1];
 578     return(y.d);
 579 }
 580
 581 #endif /* ! sparc_TARGET_ARCH */
 582
 583 #endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
 584
 585 #ifdef SUPPORT_LONG_LONGS
 586
 587 typedef struct
 588   { StgWord dhi;
 589     StgWord dlo;
 590   } unpacked_double_word;
 591
 592 typedef union
 593   { StgInt64 i;
 594     unpacked_double_word iu;
 595   } int64_thing;
 596
 597 typedef union
 598   { StgWord64 w;
 599     unpacked_double_word wu;
 600   } word64_thing;
 601
 602 INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
 603 {
 604     word64_thing y;
 605     y.w = src;
 606     p_dest[0] = y.wu.dhi;
 607     p_dest[1] = y.wu.dlo;
 608 }
 609
 610 INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
 611 {
 612     word64_thing y;
 613     y.wu.dhi = p_src[0];
 614     y.wu.dlo = p_src[1];
 615     return(y.w);
 616 }
 617
 618 INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
 619 {
 620     int64_thing y;
 621     y.i = src;
 622     p_dest[0] = y.iu.dhi;
 623     p_dest[1] = y.iu.dlo;
 624 }
 625
 626 INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
 627 {
 628     int64_thing y;
 629     y.iu.dhi = p_src[0];
 630     y.iu.dlo = p_src[1];
 631     return(y.i);
 632 }
 633
 634 #elif SIZEOF_VOID_P == 8
 635
 636 INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
 637 {
 638         p_dest[0] = src;
 639 }
 640
 641 INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
 642 {
 643     return p_src[0];
 644 }
 645
 646 INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
 647 {
 648     p_dest[0] = src;
 649 }
 650
 651 INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
 652 {
 653     return p_src[0];
 654 }
 655
 656 #endif
 657
 658 /* -----------------------------------------------------------------------------
 659    Catch frames
 660    -------------------------------------------------------------------------- */
 661
 662 extern DLL_IMPORT_RTS const StgPolyInfoTable stg_catch_frame_info;
 663
 664 /* -----------------------------------------------------------------------------
 665    Split markers
 666    -------------------------------------------------------------------------- */
 667
 668 #if defined(USE_SPLIT_MARKERS)
 669 #if defined(LEADING_UNDERSCORE)
 670 #define __STG_SPLIT_MARKER __asm__("\n___stg_split_marker:");
 671 #else
 672 #define __STG_SPLIT_MARKER __asm__("\n__stg_split_marker:");
 673 #endif
 674 #else
 675 #define __STG_SPLIT_MARKER /* nothing */
 676 #endif
 677
 678 /* -----------------------------------------------------------------------------
 679    Closure and Info Macros with casting.
 680
 681    We don't want to mess around with casts in the generated C code, so
 682    we use this casting versions of the closure macro.
 683
 684    This version of SET_HDR also includes CCS_ALLOC for profiling - the
 685    reason we don't use two separate macros is that the cost centre
 686    field is sometimes a non-simple expression and we want to share its
 687    value between SET_HDR and CCS_ALLOC.
 688    -------------------------------------------------------------------------- */
 689
 690 #define SET_HDR_(c,info,ccs,size)                               \
 691   {                                                             \
 692       CostCentreStack *tmp = (ccs);                             \
 693       SET_HDR((StgClosure *)(c),(StgInfoTable *)(info),tmp);    \
 694       CCS_ALLOC(tmp,size);                                      \
 695   }
 696
 697 /* -----------------------------------------------------------------------------
 698    Saving context for exit from the STG world, and loading up context
 699    on entry to STG code.
 700
 701    We save all the STG registers (that is, the ones that are mapped to
 702    machine registers) in their places in the TSO.
 703
 704    The stack registers go into the current stack object, and the
 705    current nursery is updated from the heap pointer.
 706
 707    These functions assume that BaseReg is loaded appropriately (if
 708    we have one).
 709    -------------------------------------------------------------------------- */
 710
 711 #if IN_STG_CODE
 712
 713 INLINE_HEADER void
 714 SaveThreadState(void)
 715 {
 716   StgTSO *tso;
 717
 718   /* Don't need to save REG_Base, it won't have changed. */
 719
 720   tso = CurrentTSO;
 721   tso->sp       = Sp;
 722   CloseNursery(Hp);
 723
 724 #ifdef REG_CurrentTSO
 725   SAVE_CurrentTSO = tso;
 726 #endif
 727 #ifdef REG_CurrentNursery
 728   SAVE_CurrentNursery = CurrentNursery;
 729 #endif
 730 #if defined(PROFILING)
 731   CurrentTSO->prof.CCCS = CCCS;
 732 #endif
 733 }
 734
 735 INLINE_HEADER void
 736 LoadThreadState (void)
 737 {
 738   StgTSO *tso;
 739
 740 #ifdef REG_CurrentTSO
 741   CurrentTSO = SAVE_CurrentTSO;
 742 #endif
 743
 744   tso = CurrentTSO;
 745   Sp    = tso->sp;
 746   SpLim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
 747   OpenNursery(Hp,HpLim);
 748
 749 #ifdef REG_CurrentNursery
 750   CurrentNursery = SAVE_CurrentNursery;
 751 #endif
 752 # if defined(PROFILING)
 753   CCCS = CurrentTSO->prof.CCCS;
 754 # endif
 755 }
 756
 757 #endif
 758
 759 /* -----------------------------------------------------------------------------
 760    Module initialisation
 761
 762    The module initialisation code looks like this, roughly:
 763
 764         FN(__stginit_Foo) {
 765           JMP_(__stginit_Foo_1_p)
 766         }
 767
 768         FN(__stginit_Foo_1_p) {
 769         ...
 770         }
 771
 772    We have one version of the init code with a module version and the
 773    'way' attached to it.  The version number helps to catch cases
 774    where modules are not compiled in dependency order before being
 775    linked: if a module has been compiled since any modules which depend on
 776    it, then the latter modules will refer to a different version in their
 777    init blocks and a link error will ensue.
 778
 779    The 'way' suffix helps to catch cases where modules compiled in different
 780    ways are linked together (eg. profiled and non-profiled).
 781
 782    We provide a plain, unadorned, version of the module init code
 783    which just jumps to the version with the label and way attached.  The
 784    reason for this is that when using foreign exports, the caller of
 785    startupHaskell() must supply the name of the init function for the "top"
 786    module in the program, and we don't want to require that this name
 787    has the version and way info appended to it.
 788    -------------------------------------------------------------------------- */
 789
 790 #define PUSH_INIT_STACK(reg_function)           \
 791         *(Sp++) = (W_)reg_function
 792
 793 #define POP_INIT_STACK()                        \
 794         *(--Sp)
 795
 796 #define MOD_INIT_WRAPPER(label,real_init)       \
 797
 798
 799 #define START_MOD_INIT(plain_lbl, real_lbl)     \
 800         static int _module_registered = 0;      \
 801         EF_(real_lbl);                          \
 802         FN_(plain_lbl) {                        \
 803             FB_                                 \
 804             JMP_(real_lbl);                     \
 805             FE_                                 \
 806         }                                       \
 807         FN_(real_lbl) {                 \
 808             FB_;                                \
 809             if (! _module_registered) {         \
 810                 _module_registered = 1;         \
 811                 {
 812             /* extern decls go here, followed by init code */
 813
 814 #define REGISTER_FOREIGN_EXPORT(reg_fe_binder)  \
 815         STGCALL1(getStablePtr,reg_fe_binder)
 816
 817 #define REGISTER_IMPORT(reg_mod_name)           \
 818         PUSH_INIT_STACK(reg_mod_name)
 819
 820 #define END_MOD_INIT()                          \
 821         }};                                     \
 822         JMP_(POP_INIT_STACK());                 \
 823         FE_ }
 824
 825 /* -----------------------------------------------------------------------------
 826    Support for _ccall_GC_ and _casm_GC.
 827    -------------------------------------------------------------------------- */
 828
 829 /*
 830  * Suspending/resuming threads for doing external C-calls (_ccall_GC).
 831  * These functions are defined in rts/Schedule.c.
 832  */
 833 StgInt        suspendThread ( StgRegTable *, rtsBool);
 834 StgRegTable * resumeThread  ( StgInt, rtsBool );
 835
 836 #define SUSPEND_THREAD(token,threaded)          \
 837    SaveThreadState();                           \
 838    token = suspendThread(BaseReg,threaded);
 839
 840 #ifdef SMP
 841 #define RESUME_THREAD(token,threaded)           \
 842     BaseReg = resumeThread(token,threaded);     \
 843     LoadThreadState();
 844 #else
 845 #define RESUME_THREAD(token,threaded)           \
 846    (void)resumeThread(token,threaded);          \
 847    LoadThreadState();
 848 #endif
 849
 850 #endif /* STGMACROS_H */
 851