StgMacros.h 25.9 KB
Newer Older
1
/* -----------------------------------------------------------------------------
sof's avatar
sof committed
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 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26
 *
 * Macros used for writing STG-ish C code.
 *
 * ---------------------------------------------------------------------------*/

#ifndef STGMACROS_H
#define STGMACROS_H

/* -----------------------------------------------------------------------------
  The following macros create function headers.

  Each basic block is represented by a C function with no arguments.
  We therefore always begin with either

  extern F_ f(void)

  or
  
  static F_ f(void)

  The macros can be used either to define the function itself, or to provide
  prototypes (by following with a ';').
sof's avatar
sof committed
27 28 29 30 31 32 33 34 35 36 37 38

  Note: the various I*_ shorthands in the second block below are used to
  declare forward references to local symbols. These shorthands *have* to
  use the 'extern' type specifier and not 'static'. The reason for this is
  that 'static' declares a reference as being a static/local variable,
  and *not* as a forward reference to a static variable.

  This might seem obvious, but it had me stumped as to why my info tables
  were suddenly all filled with 0s.

    -- sof 1/99 

39 40 41 42
  --------------------------------------------------------------------------- */

#define STGFUN(f)       StgFunPtr f(void)
#define EXTFUN(f)	extern StgFunPtr f(void)
sof's avatar
sof committed
43
#define EXTFUN_RTS(f)	extern DLL_IMPORT_RTS StgFunPtr f(void)
44 45 46
#define FN_(f)		F_ f(void)
#define IF_(f)		static F_ f(void)
#define EF_(f)		extern F_ f(void)
sof's avatar
sof committed
47
#define EDF_(f)		extern DLLIMPORT F_ f(void)
sof's avatar
sof committed
48

49 50 51 52 53 54
#define EXTINFO_RTS	extern DLL_IMPORT_RTS const StgInfoTable
#define ETI_RTS	        extern DLL_IMPORT_RTS const StgThunkInfoTable

// Info tables as generated by the compiler are simply arrays of words.
typedef StgWord StgWordArray[];

55
#define ED_		extern
rrt's avatar
rrt committed
56
#define EDD_		extern DLLIMPORT
57
#define ED_RO_		extern const
58 59
#define ID_		static
#define ID_RO_		static const
60 61 62 63
#define EI_             extern StgWordArray
#define ERI_            extern const StgRetInfoTable
#define II_             static StgWordArray
#define IRI_            static const StgRetInfoTable
64
#define EC_		extern StgClosure
sof's avatar
sof committed
65
#define EDC_		extern DLLIMPORT StgClosure
66
#define IC_		static StgClosure
67 68
#define ECP_(x)		extern const StgClosure *(x)[]
#define EDCP_(x)	extern DLLIMPORT StgClosure *(x)[]
69
#define ICP_(x)		static const StgClosure *(x)[]
70 71

/* -----------------------------------------------------------------------------
72
   Entering 
73

74 75 76
   It isn't safe to "enter" every closure.  Functions in particular
   have no entry code as such; their entry point contains the code to
   apply the function.
77 78
   -------------------------------------------------------------------------- */

79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
#define ENTER()					\
 {						\
 again:						\
  switch (get_itbl(R1.cl)->type) {		\
  case IND:					\
  case IND_OLDGEN:				\
  case IND_PERM:				\
  case IND_OLDGEN_PERM:				\
  case IND_STATIC:				\
      R1.cl = ((StgInd *)R1.cl)->indirectee;    \
      goto again;				\
  case BCO:					\
  case FUN:					\
  case FUN_1_0:					\
  case FUN_0_1:					\
  case FUN_2_0:					\
  case FUN_1_1:					\
  case FUN_0_2:					\
  case FUN_STATIC:				\
  case PAP:					\
      JMP_(ENTRY_CODE(Sp[0]));			\
  default:					\
      JMP_(GET_ENTRY(R1.cl));			\
  }						\
 }
104 105 106 107 108 109 110 111 112 113 114 115 116 117

/* -----------------------------------------------------------------------------
   Heap/Stack Checks.

   When failing a check, we save a return address on the stack and
   jump to a pre-compiled code fragment that saves the live registers
   and returns to the scheduler.

   The return address in most cases will be the beginning of the basic
   block in which the check resides, since we need to perform the check
   again on re-entry because someone else might have stolen the resource
   in the meantime.
   ------------------------------------------------------------------------- */

118 119 120 121
#define STK_CHK_FUN(headroom,assts)		\
	if (Sp - headroom < SpLim) {		\
	    assts				\
	    JMP_(stg_gc_fun);			\
122 123
	}

124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
#define HP_CHK_FUN(headroom,assts)					\
        DO_GRAN_ALLOCATE(headroom)					\
	if ((Hp += headroom) > HpLim) {					\
            HpAlloc = (headroom);					\
	    assts							\
	    JMP_(stg_gc_fun);						\
	}

// When doing both a heap and a stack check, don't move the heap
// pointer unless the stack check succeeds.  Otherwise we might end up
// with slop at the end of the current block, which can confuse the
// LDV profiler.
#define HP_STK_CHK_FUN(stk_headroom,hp_headroom,assts)			\
        DO_GRAN_ALLOCATE(hp_headroom)					\
	if (Sp - stk_headroom < SpLim || (Hp += hp_headroom) > HpLim) {	\
            HpAlloc = (hp_headroom);					\
	    assts							\
	    JMP_(stg_gc_fun);						\
	}
143 144 145 146 147 148 149 150 151 152 153 154 155

/* -----------------------------------------------------------------------------
   A Heap Check in a case alternative are much simpler: everything is
   on the stack and covered by a liveness mask already, and there is
   even a return address with an SRT info table there as well.  

   Just push R1 and return to the scheduler saying 'EnterGHC'

   {STK,HP,HP_STK}_CHK_NP are the various checking macros for
   bog-standard case alternatives, thunks, and non-top-level
   functions.  In all these cases, node points to a closure that we
   can just enter to restart the heap check (the NP stands for 'node points').

156 157 158 159
   In the NP case GranSim absolutely has to check whether the current node 
   resides on the current processor. Otherwise a FETCH event has to be
   scheduled. All that is done in GranSimFetch. -- HWL

160 161 162
   HpLim points to the LAST WORD of valid allocation space.
   -------------------------------------------------------------------------- */

163 164 165 166
#define STK_CHK_NP(headroom,tag_assts)		\
	if ((Sp - (headroom)) < SpLim) {	\
            tag_assts				\
	    JMP_(stg_gc_enter_1);		\
167 168
	}

169 170 171 172 173 174
#define HP_CHK_NP(headroom,tag_assts)					\
        DO_GRAN_ALLOCATE(headroom)					\
	if ((Hp += (headroom)) > HpLim) {				\
            HpAlloc = (headroom);					\
            tag_assts							\
	    JMP_(stg_gc_enter_1);					\
175
	}                                                       
176

177 178
// See comment on HP_STK_CHK_FUN above.
#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 188 189

/* Heap checks for branches of a primitive case / unboxed tuple return */

#define GEN_HP_CHK_ALT(headroom,lbl,tag_assts)			\
190
        DO_GRAN_ALLOCATE(headroom)                              \
191
	if ((Hp += (headroom)) > HpLim) {			\
192
            HpAlloc = (headroom);				\
193 194
            tag_assts						\
	    JMP_(lbl);						\
195
	}                                                       
196 197 198 199 200 201 202 203 204 205 206 207

#define HP_CHK_NOREGS(headroom,tag_assts) \
    GEN_HP_CHK_ALT(headroom,stg_gc_noregs,tag_assts);
#define HP_CHK_UNPT_R1(headroom,tag_assts)  \
    GEN_HP_CHK_ALT(headroom,stg_gc_unpt_r1,tag_assts);
#define HP_CHK_UNBX_R1(headroom,tag_assts)  \
    GEN_HP_CHK_ALT(headroom,stg_gc_unbx_r1,tag_assts);
#define HP_CHK_F1(headroom,tag_assts)       \
    GEN_HP_CHK_ALT(headroom,stg_gc_f1,tag_assts);
#define HP_CHK_D1(headroom,tag_assts)       \
    GEN_HP_CHK_ALT(headroom,stg_gc_d1,tag_assts);
#define HP_CHK_L1(headroom,tag_assts)       \
208
    GEN_HP_CHK_ALT(headroom,stg_gc_l1,tag_assts);
209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230

/* -----------------------------------------------------------------------------
   Generic Heap checks.

   These are slow, but have the advantage of being usable in a variety
   of situations.  

   The one restriction is that any relevant SRTs must already be pointed
   to from the stack.  The return address doesn't need to have an info
   table attached: hence it can be any old code pointer.

   The liveness mask is a logical 'XOR' of NO_PTRS and zero or more
   Rn_PTR constants defined below.  All registers will be saved, but
   the garbage collector needs to know which ones contain pointers.

   Good places to use a generic heap check: 

        - case alternatives (the return address with an SRT is already
	  on the stack).

	- primitives (no SRT required).

231
   The stack frame layout for a RET_DYN is like this:
232

233 234 235 236 237 238 239 240 241 242 243 244
          some pointers         |-- GET_PTRS(liveness) words
          some nonpointers      |-- GET_NONPTRS(liveness) words
			       
	  L1                    \
          D1-2                  |-- RET_DYN_NONPTR_REGS_SIZE words
	  F1-4                  /
			       
	  R1-8                  |-- RET_DYN_BITMAP_SIZE words
			       
	  return address        \
	  liveness mask         |-- StgRetDyn structure
	  stg_gen_chk_info      /
245

246 247
   we assume that the size of a double is always 2 pointers (wasting a
   word when it is only one pointer, but avoiding lots of #ifdefs).
248

249 250 251
   NOTE: if you change the layout of RET_DYN stack frames, then you
   might also need to adjust the value of RESERVED_STACK_WORDS in
   Constants.h.
252 253
   -------------------------------------------------------------------------- */

254
// VERY MAGIC CONSTANTS! 
255 256
// must agree with code in HeapStackCheck.c, stg_gen_chk, and
// RESERVED_STACK_WORDS in Constants.h.
257
//
258 259 260
#define RET_DYN_BITMAP_SIZE 8
#define RET_DYN_NONPTR_REGS_SIZE 10
#define ALL_NON_PTRS 0xff
261

262 263 264 265 266 267 268
// Sanity check that RESERVED_STACK_WORDS is reasonable.  We can't
// just derive RESERVED_STACK_WORDS because it's used in Haskell code
// too.
#if RESERVED_STACK_WORDS != (3 + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE)
#error RESERVED_STACK_WORDS may be wrong!
#endif

269 270
#define LIVENESS_MASK(ptr_regs)  (ALL_NON_PTRS ^ (ptr_regs))

271 272 273 274 275 276 277 278 279
// We can have up to 255 pointers and 255 nonpointers in the stack
// frame.
#define N_NONPTRS(n)  ((n)<<16)
#define N_PTRS(n)     ((n)<<24)

#define GET_NONPTRS(l) ((l)>>16 & 0xff)
#define GET_PTRS(l)    ((l)>>24 & 0xff)
#define GET_LIVENESS(l) ((l) & 0xffff)

280 281 282 283 284 285 286 287 288
#define NO_PTRS   0
#define R1_PTR	  1<<0
#define R2_PTR	  1<<1
#define R3_PTR	  1<<2
#define R4_PTR	  1<<3
#define R5_PTR	  1<<4
#define R6_PTR	  1<<5
#define R7_PTR	  1<<6
#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 299 300 301 302 303 304 305 306 307
#define HP_CHK_GEN(headroom,liveness,reentry)			\
   if ((Hp += (headroom)) > HpLim ) {				\
        HpAlloc = (headroom);					\
	R9.w = (W_)LIVENESS_MASK(liveness);			\
        R10.w = (W_)reentry;					\
        JMP_(stg_gc_gen);					\
    }                                                       

#define HP_CHK_GEN_TICKY(headroom,liveness,reentry)	\
   HP_CHK_GEN(headroom,liveness,reentry);		\
308
   TICK_ALLOC_HEAP_NOCTR(headroom)
309

310
#define STK_CHK_GEN(headroom,liveness,reentry)	\
311 312 313
   if ((Sp - (headroom)) < SpLim) {				\
	R9.w = (W_)LIVENESS_MASK(liveness);			\
        R10.w = (W_)reentry;					\
314
        JMP_(stg_gc_gen);					\
315
   }
316 317 318 319 320

#define MAYBE_GC(liveness,reentry)		\
   if (doYouWantToGC()) {			\
	R9.w = (W_)LIVENESS_MASK(liveness);	\
        R10.w = (W_)reentry;			\
321
        JMP_(stg_gc_gen_hp);			\
322 323 324 325 326 327 328 329 330
   }

/* -----------------------------------------------------------------------------
   Voluntary Yields/Blocks

   We only have a generic version of this at the moment - if it turns
   out to be slowing us down we can make specialised ones.
   -------------------------------------------------------------------------- */

rrt's avatar
rrt committed
331 332
EXTFUN_RTS(stg_gen_yield);
EXTFUN_RTS(stg_gen_block);
sof's avatar
sof committed
333

334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
#define YIELD(liveness,reentry)			\
  {						\
   R9.w  = (W_)LIVENESS_MASK(liveness);		\
   R10.w = (W_)reentry;				\
   JMP_(stg_gen_yield);				\
  }

#define BLOCK(liveness,reentry)			\
  {						\
   R9.w  = (W_)LIVENESS_MASK(liveness);		\
   R10.w = (W_)reentry;				\
   JMP_(stg_gen_block);				\
  }

#define BLOCK_NP(ptrs)				\
  {						\
rrt's avatar
rrt committed
350
    EXTFUN_RTS(stg_block_##ptrs);			\
351 352 353
    JMP_(stg_block_##ptrs);			\
  }

354 355 356 357 358 359 360 361 362 363 364 365 366 367
#if defined(PAR)
/*
  Similar to BLOCK_NP but separates the saving of the thread state from the
  actual jump via an StgReturn
*/

#define SAVE_THREAD_STATE(ptrs)                  \
  ASSERT(ptrs==1);                               \
  Sp -= 1;                                       \
  Sp[0] = R1.w;                                  \
  SaveThreadState();                             

#define THREAD_RETURN(ptrs)                      \
  ASSERT(ptrs==1);                               \
368
  CurrentTSO->what_next = ThreadEnterGHC;        \
369 370 371 372
  R1.i = ThreadBlocked;                          \
  JMP_(StgReturn);                               
#endif

373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388
/* -----------------------------------------------------------------------------
   CCall_GC needs to push a dummy stack frame containing the contents
   of volatile registers and variables.  

   We use a RET_DYN frame the same as for a dynamic heap check.
   ------------------------------------------------------------------------- */

/* -----------------------------------------------------------------------------
   Vectored Returns

   RETVEC(p,t) where 'p' is a pointer to the info table for a
   vectored return address, returns the address of the return code for
   tag 't'.

   Return vectors are placed in *reverse order* immediately before the info
   table for the return address.  Hence the formula for computing the
389
   actual return address is (addr - sizeof(RetInfoTable) - tag - 1).
390 391 392
   The extra subtraction of one word is because tags start at zero.
   -------------------------------------------------------------------------- */

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 398 399 400 401 402
#endif

/* -----------------------------------------------------------------------------
   Misc
   -------------------------------------------------------------------------- */

403

404 405 406
/* set the tag register (if we have one) */
#define SET_TAG(t)  /* nothing */

407
#ifdef EAGER_BLACKHOLING
408
#  ifdef SMP
409 410 411 412
#    define UPD_BH_UPDATABLE(info)				\
        TICK_UPD_BH_UPDATABLE();				\
        { 							\
	  bdescr *bd = Bdescr(R1.p);				\
sof's avatar
sof committed
413 414
          if (bd->u.back != (bdescr *)BaseReg) {		\
             if (bd->gen_no >= 1 || bd->step->no >= 1) {	\
415 416 417 418 419 420 421
        	 LOCK_THUNK(info);				\
             } else {						\
	         EXTFUN_RTS(stg_gc_enter_1_hponly);		\
        	 JMP_(stg_gc_enter_1_hponly);			\
             }							\
          }							\
	}							\
422
        SET_INFO(R1.cl,&stg_BLACKHOLE_info)
423 424 425 426
#    define UPD_BH_SINGLE_ENTRY(info)				\
        TICK_UPD_BH_SINGLE_ENTRY();				\
        {							\
	  bdescr *bd = Bdescr(R1.p);				\
sof's avatar
sof committed
427 428
          if (bd->u.back != (bdescr *)BaseReg) {		\
             if (bd->gen_no >= 1 || bd->step->no >= 1) {	\
429 430 431 432 433 434 435
        	 LOCK_THUNK(info);				\
             } else {						\
	         EXTFUN_RTS(stg_gc_enter_1_hponly);		\
        	 JMP_(stg_gc_enter_1_hponly);			\
             }							\
          }							\
	}							\
436
        SET_INFO(R1.cl,&stg_BLACKHOLE_info)
437
#  else
438
#   ifndef PROFILING
439 440
#    define UPD_BH_UPDATABLE(info)		\
        TICK_UPD_BH_UPDATABLE();		\
441
        SET_INFO(R1.cl,&stg_BLACKHOLE_info)
442 443
#    define UPD_BH_SINGLE_ENTRY(info)		\
        TICK_UPD_BH_SINGLE_ENTRY();		\
444
        SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info)
445 446 447
#   else
// An object is replaced by a blackhole, so we fill the slop with zeros.
// 
448 449
// This looks like it can't work - we're overwriting the contents of
// the THUNK with slop!  Perhaps this never worked??? --SDM
450 451 452 453 454
// The problem is that with eager-black-holing we currently perform
// the black-holing operation at the *beginning* of the basic block,
// when we still need the contents of the thunk.
// Perhaps the thing to do is to overwrite it at the *end* of the
// basic block, when we've already sucked out the thunk's contents? -- SLPJ
455
//
456 457 458 459 460 461 462 463 464 465 466 467 468
// Todo: maybe use SET_HDR() and remove LDV_recordCreate()?
// 
#    define UPD_BH_UPDATABLE(info)		\
        TICK_UPD_BH_UPDATABLE();		\
        LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl);               \
        SET_INFO(R1.cl,&stg_BLACKHOLE_info);    \
        LDV_recordCreate(R1.cl)
#    define UPD_BH_SINGLE_ENTRY(info)		\
        TICK_UPD_BH_SINGLE_ENTRY();		\
        LDV_recordDead_FILL_SLOP_DYNAMIC(R1.cl);               \
        SET_INFO(R1.cl,&stg_SE_BLACKHOLE_info)  \
        LDV_recordCreate(R1.cl)
#   endif /* PROFILING */
469
#  endif
470 471 472 473
#else /* !EAGER_BLACKHOLING */
#  define UPD_BH_UPDATABLE(thunk)    /* nothing */
#  define UPD_BH_SINGLE_ENTRY(thunk) /* nothing */
#endif /* EAGER_BLACKHOLING */
474 475 476 477 478 479

/* -----------------------------------------------------------------------------
   Moving Floats and Doubles

   ASSIGN_FLT is for assigning a float to memory (usually the
              stack/heap).  The memory address is guaranteed to be
480
	      StgWord aligned (currently == sizeof(void *)).
481 482 483 484 485

   PK_FLT     is for pulling a float out of memory.  The memory is
              guaranteed to be StgWord aligned.
   -------------------------------------------------------------------------- */

sof's avatar
sof committed
486 487
INLINE_HEADER void	  ASSIGN_FLT (W_ [], StgFloat);
INLINE_HEADER StgFloat    PK_FLT     (W_ []);
488 489 490

#if ALIGNMENT_FLOAT <= ALIGNMENT_LONG

sof's avatar
sof committed
491 492
INLINE_HEADER void     ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
INLINE_HEADER StgFloat PK_FLT    (W_ p_src[])                { return *(StgFloat *)p_src; }
493 494 495

#else  /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */

sof's avatar
sof committed
496
INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
497 498 499 500 501 502
{
    float_thing y;
    y.f = src;
    *p_dest = y.fu;
}

sof's avatar
sof committed
503
INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
504 505 506 507 508 509 510 511 512 513
{
    float_thing y;
    y.fu = *p_src;
    return(y.f);
}

#endif /* ALIGNMENT_FLOAT > ALIGNMENT_LONG */

#if ALIGNMENT_DOUBLE <= ALIGNMENT_LONG

sof's avatar
sof committed
514 515
INLINE_HEADER void	  ASSIGN_DBL (W_ [], StgDouble);
INLINE_HEADER StgDouble   PK_DBL     (W_ []);
516

sof's avatar
sof committed
517 518
INLINE_HEADER void      ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
INLINE_HEADER StgDouble PK_DBL    (W_ p_src[])                 { return *(StgDouble *)p_src; }
519 520 521 522 523 524 525 526 527 528

#else	/* ALIGNMENT_DOUBLE > ALIGNMENT_LONG */

/* Sparc uses two floating point registers to hold a double.  We can
 * write ASSIGN_DBL and PK_DBL by directly accessing the registers
 * independently - unfortunately this code isn't writable in C, we
 * have to use inline assembler.
 */
#if sparc_TARGET_ARCH

529 530
#define ASSIGN_DBL(dst0,src) \
    { StgPtr dst = (StgPtr)(dst0); \
531
      __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
532 533
	"=m" (((P_)(dst))[1]) : "f" (src)); \
    }
534

535 536 537
#define PK_DBL(src0) \
    ( { StgPtr src = (StgPtr)(src0); \
        register double d; \
538 539 540 541 542 543
      __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
	"m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
    } )

#else /* ! sparc_TARGET_ARCH */

sof's avatar
sof committed
544 545
INLINE_HEADER void	  ASSIGN_DBL (W_ [], StgDouble);
INLINE_HEADER StgDouble   PK_DBL     (W_ []);
546 547 548 549 550 551 552 553 554 555 556

typedef struct
  { StgWord dhi;
    StgWord dlo;
  } unpacked_double;

typedef union
  { StgDouble d;
    unpacked_double du;
  } double_thing;

sof's avatar
sof committed
557
INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
558 559 560 561 562 563 564 565 566 567 568 569 570 571 572
{
    double_thing y;
    y.d = src;
    p_dest[0] = y.du.dhi;
    p_dest[1] = y.du.dlo;
}

/* GCC also works with this version, but it generates
   the same code as the previous one, and is not ANSI

#define ASSIGN_DBL( p_dest, src ) \
	*p_dest = ((double_thing) src).du.dhi; \
	*(p_dest+1) = ((double_thing) src).du.dlo \
*/

sof's avatar
sof committed
573
INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597
{
    double_thing y;
    y.du.dhi = p_src[0];
    y.du.dlo = p_src[1];
    return(y.d);
}

#endif /* ! sparc_TARGET_ARCH */

#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */

#ifdef SUPPORT_LONG_LONGS

typedef struct
  { StgWord dhi;
    StgWord dlo;
  } unpacked_double_word;

typedef union
  { StgInt64 i;
    unpacked_double_word iu;
  } int64_thing;

typedef union
sof's avatar
sof committed
598
  { StgWord64 w;
599 600 601
    unpacked_double_word wu;
  } word64_thing;

sof's avatar
sof committed
602
INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
603 604 605 606 607 608 609
{
    word64_thing y;
    y.w = src;
    p_dest[0] = y.wu.dhi;
    p_dest[1] = y.wu.dlo;
}

sof's avatar
sof committed
610
INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
611 612 613 614 615 616 617
{
    word64_thing y;
    y.wu.dhi = p_src[0];
    y.wu.dlo = p_src[1];
    return(y.w);
}

sof's avatar
sof committed
618
INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
619 620 621 622 623 624 625
{
    int64_thing y;
    y.i = src;
    p_dest[0] = y.iu.dhi;
    p_dest[1] = y.iu.dlo;
}

sof's avatar
sof committed
626
INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
627 628 629 630 631 632
{
    int64_thing y;
    y.iu.dhi = p_src[0];
    y.iu.dlo = p_src[1];
    return(y.i);
}
ken's avatar
ken committed
633 634 635

#elif SIZEOF_VOID_P == 8

sof's avatar
sof committed
636
INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
ken's avatar
ken committed
637 638 639 640
{
	p_dest[0] = src;
}

sof's avatar
sof committed
641
INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
ken's avatar
ken committed
642 643 644 645
{
    return p_src[0];
}

sof's avatar
sof committed
646
INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
ken's avatar
ken committed
647 648 649 650
{
    p_dest[0] = src;
}

sof's avatar
sof committed
651
INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
ken's avatar
ken committed
652 653 654 655
{
    return p_src[0];
}

656 657 658 659 660 661
#endif

/* -----------------------------------------------------------------------------
   Catch frames
   -------------------------------------------------------------------------- */

662
extern DLL_IMPORT_RTS const StgPolyInfoTable stg_catch_frame_info;
663 664 665 666 667 668

/* -----------------------------------------------------------------------------
   Split markers
   -------------------------------------------------------------------------- */

#if defined(USE_SPLIT_MARKERS)
669
#if defined(LEADING_UNDERSCORE)
670 671
#define __STG_SPLIT_MARKER __asm__("\n___stg_split_marker:");
#else
672
#define __STG_SPLIT_MARKER __asm__("\n__stg_split_marker:");
673
#endif
674
#else
675
#define __STG_SPLIT_MARKER /* nothing */
676 677 678 679 680 681
#endif

/* -----------------------------------------------------------------------------
   Closure and Info Macros with casting.

   We don't want to mess around with casts in the generated C code, so
682 683 684 685 686 687
   we use this casting versions of the closure macro.

   This version of SET_HDR also includes CCS_ALLOC for profiling - the
   reason we don't use two separate macros is that the cost centre
   field is sometimes a non-simple expression and we want to share its
   value between SET_HDR and CCS_ALLOC.
688 689
   -------------------------------------------------------------------------- */

690 691 692 693 694 695
#define SET_HDR_(c,info,ccs,size)				\
  {								\
      CostCentreStack *tmp = (ccs);				\
      SET_HDR((StgClosure *)(c),(StgInfoTable *)(info),tmp);	\
      CCS_ALLOC(tmp,size);					\
  }
696 697 698 699 700 701 702 703

/* -----------------------------------------------------------------------------
   Saving context for exit from the STG world, and loading up context
   on entry to STG code.

   We save all the STG registers (that is, the ones that are mapped to
   machine registers) in their places in the TSO.  

704 705 706 707 708
   The stack registers go into the current stack object, and the
   current nursery is updated from the heap pointer.

   These functions assume that BaseReg is loaded appropriately (if
   we have one).
709 710
   -------------------------------------------------------------------------- */

711
#if IN_STG_CODE
712

sof's avatar
sof committed
713
INLINE_HEADER void
714 715
SaveThreadState(void)
{
716 717
  StgTSO *tso;

718 719
  /* Don't need to save REG_Base, it won't have changed. */

720 721
  tso = CurrentTSO;
  tso->sp       = Sp;
722 723
  CloseNursery(Hp);

724
#ifdef REG_CurrentTSO
725
  SAVE_CurrentTSO = tso;
726 727 728 729
#endif
#ifdef REG_CurrentNursery
  SAVE_CurrentNursery = CurrentNursery;
#endif
730 731 732 733 734
#if defined(PROFILING)
  CurrentTSO->prof.CCCS = CCCS;
#endif
}

sof's avatar
sof committed
735
INLINE_HEADER void 
736 737
LoadThreadState (void)
{
738
  StgTSO *tso;
739

740 741 742
#ifdef REG_CurrentTSO
  CurrentTSO = SAVE_CurrentTSO;
#endif
743 744 745

  tso = CurrentTSO;
  Sp    = tso->sp;
746
  SpLim = (P_)&(tso->stack) + RESERVED_STACK_WORDS;
747 748
  OpenNursery(Hp,HpLim);

749 750 751
#ifdef REG_CurrentNursery
  CurrentNursery = SAVE_CurrentNursery;
#endif
752 753 754 755 756
# if defined(PROFILING)
  CCCS = CurrentTSO->prof.CCCS;
# endif
}

757 758
#endif

759 760
/* -----------------------------------------------------------------------------
   Module initialisation
761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787

   The module initialisation code looks like this, roughly:

	FN(__stginit_Foo) {
 	  JMP_(__stginit_Foo_1_p)
	}

	FN(__stginit_Foo_1_p) {
	...
	}

   We have one version of the init code with a module version and the
   'way' attached to it.  The version number helps to catch cases
   where modules are not compiled in dependency order before being
   linked: if a module has been compiled since any modules which depend on
   it, then the latter modules will refer to a different version in their
   init blocks and a link error will ensue.

   The 'way' suffix helps to catch cases where modules compiled in different
   ways are linked together (eg. profiled and non-profiled).

   We provide a plain, unadorned, version of the module init code
   which just jumps to the version with the label and way attached.  The
   reason for this is that when using foreign exports, the caller of
   startupHaskell() must supply the name of the init function for the "top"
   module in the program, and we don't want to require that this name
   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 797 798 799
#define MOD_INIT_WRAPPER(label,real_init)	\


#define START_MOD_INIT(plain_lbl, real_lbl)	\
800
	static int _module_registered = 0;	\
801 802 803 804 805 806 807
	EF_(real_lbl);				\
	FN_(plain_lbl) {			\
            FB_					\
            JMP_(real_lbl);			\
	    FE_					\
        }					\
	FN_(real_lbl) {			\
808 809 810 811 812 813 814 815 816 817
	    FB_;				\
	    if (! _module_registered) {		\
	        _module_registered = 1;		\
		{ 
	    /* extern decls go here, followed by init code */

#define REGISTER_FOREIGN_EXPORT(reg_fe_binder)	\
        STGCALL1(getStablePtr,reg_fe_binder)
	
#define REGISTER_IMPORT(reg_mod_name)		\
rrt's avatar
rrt committed
818 819
        PUSH_INIT_STACK(reg_mod_name)

820 821 822 823 824
#define END_MOD_INIT()				\
        }};					\
	JMP_(POP_INIT_STACK());			\
	FE_ }

825 826 827
/* -----------------------------------------------------------------------------
   Support for _ccall_GC_ and _casm_GC.
   -------------------------------------------------------------------------- */
828

829 830 831 832
/* 
 * Suspending/resuming threads for doing external C-calls (_ccall_GC).
 * These functions are defined in rts/Schedule.c.
 */
sof's avatar
sof committed
833 834
StgInt        suspendThread ( StgRegTable *, rtsBool);
StgRegTable * resumeThread  ( StgInt, rtsBool );
835

sof's avatar
sof committed
836
#define SUSPEND_THREAD(token,threaded)		\
837
   SaveThreadState();				\
sof's avatar
sof committed
838
   token = suspendThread(BaseReg,threaded);
839 840

#ifdef SMP
sof's avatar
sof committed
841 842
#define RESUME_THREAD(token,threaded)		\
    BaseReg = resumeThread(token,threaded);	\
843
    LoadThreadState();
844
#else
sof's avatar
sof committed
845 846
#define RESUME_THREAD(token,threaded)		\
   (void)resumeThread(token,threaded);		\
847 848 849
   LoadThreadState();
#endif

850 851
#endif /* STGMACROS_H */