path: root/includes/Cmm.h

/* -----------------------------------------------------------------------------
 *
 * (c) The University of Glasgow 2004-2013
 *
 * This file is included at the top of all .cmm source files (and
 * *only* .cmm files).  It defines a collection of useful macros for
 * making .cmm code a bit less error-prone to write, and a bit easier
 * on the eye for the reader.
 *
 * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
 *
 * Accessing fields of structures defined in the RTS header files is
 * done via automatically-generated macros in DerivedConstants.h.  For
 * example, where previously we used
 *
 *          CurrentTSO->what_next = x
 *
 * in C-- we now use
 *
 *          StgTSO_what_next(CurrentTSO) = x
 *
 * where the StgTSO_what_next() macro is automatically generated by
 * mkDerivedConstants.c.  If you need to access a field that doesn't
 * already have a macro, edit that file (it's pretty self-explanatory).
 *
 * -------------------------------------------------------------------------- */

#pragma once

/*
 * In files that are included into both C and C-- (and perhaps
 * Haskell) sources, we sometimes need to conditionally compile bits
 * depending on the language.  CMINUSMINUS==1 in .cmm sources:
 */
#define CMINUSMINUS 1

#include "ghcconfig.h"

/* -----------------------------------------------------------------------------
   Types

   The following synonyms for C-- types are declared here:

     I8, I16, I32, I64    MachRep-style names for convenience

     W_                   is shorthand for the word type (== StgWord)
     F_                   shorthand for float  (F_ == StgFloat == C's float)
     D_                   shorthand for double (D_ == StgDouble == C's double)

     CInt                 has the same size as an int in C on this platform
     CLong                has the same size as a long in C on this platform
     CBool                has the same size as a bool in C on this platform

  --------------------------------------------------------------------------- */

#define I8  bits8
#define I16 bits16
#define I32 bits32
#define I64 bits64
#define P_  gcptr

#if SIZEOF_VOID_P == 4
#define W_ bits32
/* Maybe it's better to include MachDeps.h */
#define TAG_BITS                2
#elif SIZEOF_VOID_P == 8
#define W_ bits64
/* Maybe it's better to include MachDeps.h */
#define TAG_BITS                3
#else
#error Unknown word size
#endif

/*
 * The RTS must sometimes UNTAG a pointer before dereferencing it.
 * See the wiki page commentary/rts/haskell-execution/pointer-tagging
 */
#define TAG_MASK ((1 << TAG_BITS) - 1)
#define UNTAG(p) (p & ~TAG_MASK)
#define GETTAG(p) (p & TAG_MASK)

#if SIZEOF_INT == 4
#define CInt bits32
#elif SIZEOF_INT == 8
#define CInt bits64
#else
#error Unknown int size
#endif

#if SIZEOF_LONG == 4
#define CLong bits32
#elif SIZEOF_LONG == 8
#define CLong bits64
#else
#error Unknown long size
#endif

#define CBool bits8

#define F_   float32
#define D_   float64
#define L_   bits64
#define V16_ bits128
#define V32_ bits256
#define V64_ bits512

#define SIZEOF_StgDouble 8
#define SIZEOF_StgWord64 8

/* -----------------------------------------------------------------------------
   Misc useful stuff
   -------------------------------------------------------------------------- */

#define ccall foreign "C"

#define NULL (0::W_)

#define STRING(name,str)                        \
  section "rodata" {                            \
        name : bits8[] str;                     \
  }                                             \

#if defined(TABLES_NEXT_TO_CODE)
#define RET_LBL(f) f##_info
#else
#define RET_LBL(f) f##_ret
#endif

#if defined(TABLES_NEXT_TO_CODE)
#define ENTRY_LBL(f) f##_info
#else
#define ENTRY_LBL(f) f##_entry
#endif

/* -----------------------------------------------------------------------------
   Byte/word macros

   Everything in C-- is in byte offsets (well, most things).  We use
   some macros to allow us to express offsets in words and to try to
   avoid byte/word confusion.
   -------------------------------------------------------------------------- */

#define SIZEOF_W  SIZEOF_VOID_P
#define W_MASK    (SIZEOF_W-1)

#if SIZEOF_W == 4
#define W_SHIFT 2
#elif SIZEOF_W == 8
#define W_SHIFT 3
#endif

/* Converting quantities of words to bytes */
#define WDS(n) ((n)*SIZEOF_W)

/*
 * Converting quantities of bytes to words
 * NB. these work on *unsigned* values only
 */
#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)
#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)

/* TO_W_(n) converts n to W_ type from a smaller type */
#if SIZEOF_W == 4
#define TO_I64(x) %sx64(x)
#define TO_W_(x) %sx32(x)
#define HALF_W_(x) %lobits16(x)
#elif SIZEOF_W == 8
#define TO_I64(x) (x)
#define TO_W_(x) %sx64(x)
#define HALF_W_(x) %lobits32(x)
#endif

#if SIZEOF_INT == 4 && SIZEOF_W == 8
#define W_TO_INT(x) %lobits32(x)
#elif SIZEOF_INT == SIZEOF_W
#define W_TO_INT(x) (x)
#endif

#if SIZEOF_LONG == 4 && SIZEOF_W == 8
#define W_TO_LONG(x) %lobits32(x)
#elif SIZEOF_LONG == SIZEOF_W
#define W_TO_LONG(x) (x)
#endif

/* -----------------------------------------------------------------------------
   Atomic memory operations.
   -------------------------------------------------------------------------- */

#if SIZEOF_W == 4
#define cmpxchgW cmpxchg32
#elif SIZEOF_W == 8
#define cmpxchgW cmpxchg64
#endif

/* -----------------------------------------------------------------------------
   Heap/stack access, and adjusting the heap/stack pointers.
   -------------------------------------------------------------------------- */

#define Sp(n)  W_[Sp + WDS(n)]
#define Hp(n)  W_[Hp + WDS(n)]

#define Sp_adj(n) Sp = Sp + WDS(n)  /* pronounced "spadge" */
#define Hp_adj(n) Hp = Hp + WDS(n)

/* -----------------------------------------------------------------------------
   Assertions and Debuggery
   -------------------------------------------------------------------------- */

#if defined(DEBUG)
#define ASSERT(predicate)                       \
        if (predicate) {                        \
            /*null*/;                           \
        } else {                                \
            foreign "C" _assertFail(__FILE__, __LINE__) never returns; \
        }
#else
#define ASSERT(p) /* nothing */
#endif

#if defined(DEBUG)
#define DEBUG_ONLY(s) s
#else
#define DEBUG_ONLY(s) /* nothing */
#endif

/*
 * The IF_DEBUG macro is useful for debug messages that depend on one
 * of the RTS debug options.  For example:
 *
 *   IF_DEBUG(RtsFlags_DebugFlags_apply,
 *      foreign "C" fprintf(stderr, stg_ap_0_ret_str));
 *
 * Note the syntax is slightly different to the C version of this macro.
 */
#if defined(DEBUG)
#define IF_DEBUG(c,s)  if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; }
#else
#define IF_DEBUG(c,s)  /* nothing */
#endif

/* -----------------------------------------------------------------------------
   Entering

   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.

   ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,
   but switch doesn't allow us to use exprs there yet.

   If R1 points to a tagged object it points either to
   * A constructor.
   * A function with arity <= TAG_MASK.
   In both cases the right thing to do is to return.
   Note: it is rather lucky that we can use the tag bits to do this
         for both objects. Maybe it points to a brittle design?

   Indirections can contain tagged pointers, so their tag is checked.
   -------------------------------------------------------------------------- */

#if defined(PROFILING)

// When profiling, we cannot shortcut ENTER() by checking the tag,
// because LDV profiling relies on entering closures to mark them as
// "used".

#define LOAD_INFO(ret,x)                        \
    info = %INFO_PTR(UNTAG(x));

#define UNTAG_IF_PROF(x) UNTAG(x)

#else

#define LOAD_INFO(ret,x)                        \
  if (GETTAG(x) != 0) {                         \
      ret(x);                                   \
  }                                             \
  info = %INFO_PTR(x);

#define UNTAG_IF_PROF(x) (x) /* already untagged */

#endif

// We need two versions of ENTER():
//  - ENTER(x) takes the closure as an argument and uses return(),
//    for use in civilized code where the stack is handled by GHC
//
//  - ENTER_NOSTACK() where the closure is in R1, and returns are
//    explicit jumps, for use when we are doing the stack management
//    ourselves.

#if defined(PROFILING)
// See Note [Evaluating functions with profiling] in rts/Apply.cmm
#define ENTER(x) jump stg_ap_0_fast(x);
#else
#define ENTER(x) ENTER_(return,x)
#endif

#define ENTER_R1() ENTER_(RET_R1,R1)

#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]

#define ENTER_(ret,x)                                   \
 again:                                                 \
  W_ info;                                              \
  LOAD_INFO(ret,x)                                       \
  switch [INVALID_OBJECT .. N_CLOSURE_TYPES]            \
         (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \
  case                                                  \
    IND,                                                \
    IND_STATIC:                                         \
   {                                                    \
      x = StgInd_indirectee(x);                         \
      goto again;                                       \
   }                                                    \
  case                                                  \
    FUN,                                                \
    FUN_1_0,                                            \
    FUN_0_1,                                            \
    FUN_2_0,                                            \
    FUN_1_1,                                            \
    FUN_0_2,                                            \
    FUN_STATIC,                                         \
    BCO,                                                \
    PAP:                                                \
   {                                                    \
       ret(x);                                          \
   }                                                    \
  default:                                              \
   {                                                    \
       x = UNTAG_IF_PROF(x);                            \
       jump %ENTRY_CODE(info) (x);                      \
   }                                                    \
  }

// The FUN cases almost never happen: a pointer to a non-static FUN
// should always be tagged.  This unfortunately isn't true for the
// interpreter right now, which leaves untagged FUNs on the stack.

/* -----------------------------------------------------------------------------
   Constants.
   -------------------------------------------------------------------------- */

#include "rts/Constants.h"
#include "DerivedConstants.h"
#include "rts/storage/ClosureTypes.h"
#include "rts/storage/FunTypes.h"
#include "rts/OSThreads.h"

/*
 * Need MachRegs, because some of the RTS code is conditionally
 * compiled based on REG_R1, REG_R2, etc.
 */
#include "stg/RtsMachRegs.h"

#include "rts/prof/LDV.h"

#undef BLOCK_SIZE
#undef MBLOCK_SIZE
#include "rts/storage/Block.h"  /* For Bdescr() */


#define MyCapability()  (BaseReg - OFFSET_Capability_r)

/* -------------------------------------------------------------------------
   Info tables
   ------------------------------------------------------------------------- */

#if defined(PROFILING)
#define PROF_HDR_FIELDS(w_,hdr1,hdr2)          \
  w_ hdr1,                                     \
  w_ hdr2,
#else
#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */
#endif

/* -------------------------------------------------------------------------
   Allocation and garbage collection
   ------------------------------------------------------------------------- */

/*
 * ALLOC_PRIM is for allocating memory on the heap for a primitive
 * object.  It is used all over PrimOps.cmm.
 *
 * We make the simplifying assumption that the "admin" part of a
 * primitive closure is just the header when calculating sizes for
 * ticky-ticky.  It's not clear whether eg. the size field of an array
 * should be counted as "admin", or the various fields of a BCO.
 */
#define ALLOC_PRIM(bytes)                                       \
   HP_CHK_GEN_TICKY(bytes);                                     \
   TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0);  \
   CCCS_ALLOC(bytes);

#define HEAP_CHECK(bytes,failure)                       \
    TICK_BUMP(HEAP_CHK_ctr);                            \
    Hp = Hp + (bytes);                                  \
    if (Hp > HpLim) { HpAlloc = (bytes); failure; }     \
    TICK_ALLOC_HEAP_NOCTR(bytes);

#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure)           \
    HEAP_CHECK(bytes,failure)                                   \
    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
    CCCS_ALLOC(bytes);

#define ALLOC_PRIM_(bytes,fun)                                  \
    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));

#define ALLOC_PRIM_P(bytes,fun,arg)                             \
    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));

#define ALLOC_PRIM_N(bytes,fun,arg)                             \
    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));

/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */
#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)

#define HP_CHK_GEN_TICKY(bytes)                 \
   HP_CHK_GEN(bytes);                           \
   TICK_ALLOC_HEAP_NOCTR(bytes);

#define HP_CHK_P(bytes, fun, arg)               \
   HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))

// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed?
//         -NSF March 2013
#define ALLOC_P_TICKY(bytes, fun, arg)          \
   HP_CHK_P(bytes);                             \
   TICK_ALLOC_HEAP_NOCTR(bytes);

#define CHECK_GC()                                                      \
  (bdescr_link(CurrentNursery) == NULL ||                               \
   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))

// allocate() allocates from the nursery, so we check to see
// whether the nursery is nearly empty in any function that uses
// allocate() - this includes many of the primops.
//
// HACK alert: the __L__ stuff is here to coax the common-block
// eliminator into commoning up the call stg_gc_noregs() with the same
// code that gets generated by a STK_CHK_GEN() in the same proc.  We
// also need an if (0) { goto __L__; } so that the __L__ label isn't
// optimised away by the control-flow optimiser prior to common-block
// elimination (it will be optimised away later).
//
// This saves some code in gmp-wrappers.cmm where we have lots of
// MAYBE_GC() in the same proc as STK_CHK_GEN().
//
#define MAYBE_GC(retry)                         \
    if (CHECK_GC()) {                           \
        HpAlloc = 0;                            \
        goto __L__;                             \
  __L__:                                        \
        call stg_gc_noregs();                   \
        goto retry;                             \
   }                                            \
   if (0) { goto __L__; }

#define GC_PRIM(fun)                            \
        jump stg_gc_prim(fun);

// Version of GC_PRIM for use in low-level Cmm.  We can call
// stg_gc_prim, because it takes one argument and therefore has a
// platform-independent calling convention (Note [Syntax of .cmm
// files] in CmmParse.y).
#define GC_PRIM_LL(fun)                         \
        R1 = fun;                               \
        jump stg_gc_prim [R1];

// We pass the fun as the second argument, because the arg is
// usually already in the first argument position (R1), so this
// avoids moving it to a different register / stack slot.
#define GC_PRIM_N(fun,arg)                      \
        jump stg_gc_prim_n(arg,fun);

#define GC_PRIM_P(fun,arg)                      \
        jump stg_gc_prim_p(arg,fun);

#define GC_PRIM_P_LL(fun,arg)                   \
        R1 = arg;                               \
        R2 = fun;                               \
        jump stg_gc_prim_p_ll [R1,R2];

#define GC_PRIM_PP(fun,arg1,arg2)               \
        jump stg_gc_prim_pp(arg1,arg2,fun);

#define MAYBE_GC_(fun)                          \
    if (CHECK_GC()) {                           \
        HpAlloc = 0;                            \
        GC_PRIM(fun)                            \
   }

#define MAYBE_GC_N(fun,arg)                     \
    if (CHECK_GC()) {                           \
        HpAlloc = 0;                            \
        GC_PRIM_N(fun,arg)                      \
   }

#define MAYBE_GC_P(fun,arg)                     \
    if (CHECK_GC()) {                           \
        HpAlloc = 0;                            \
        GC_PRIM_P(fun,arg)                      \
   }

#define MAYBE_GC_PP(fun,arg1,arg2)              \
    if (CHECK_GC()) {                           \
        HpAlloc = 0;                            \
        GC_PRIM_PP(fun,arg1,arg2)               \
   }

#define STK_CHK_LL(n, fun)                      \
    TICK_BUMP(STK_CHK_ctr);                     \
    if (Sp - (n) < SpLim) {                     \
        GC_PRIM_LL(fun)                         \
    }

#define STK_CHK_P_LL(n, fun, arg)               \
    TICK_BUMP(STK_CHK_ctr);                     \
    if (Sp - (n) < SpLim) {                     \
        GC_PRIM_P_LL(fun,arg)                   \
    }

#define STK_CHK_PP(n, fun, arg1, arg2)          \
    TICK_BUMP(STK_CHK_ctr);                     \
    if (Sp - (n) < SpLim) {                     \
        GC_PRIM_PP(fun,arg1,arg2)               \
    }

#define STK_CHK_ENTER(n, closure)               \
    TICK_BUMP(STK_CHK_ctr);                     \
    if (Sp - (n) < SpLim) {                     \
        jump __stg_gc_enter_1(closure);         \
    }

// A funky heap check used by AutoApply.cmm

#define HP_CHK_NP_ASSIGN_SP0(size,f)                    \
    HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)

/* -----------------------------------------------------------------------------
   Closure headers
   -------------------------------------------------------------------------- */

/*
 * This is really ugly, since we don't do the rest of StgHeader this
 * way.  The problem is that values from DerivedConstants.h cannot be
 * dependent on the way (SMP, PROF etc.).  For SIZEOF_StgHeader we get
 * the value from GHC, but it seems like too much trouble to do that
 * for StgThunkHeader.
 */
#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader

#define StgThunk_payload(__ptr__,__ix__) \
    W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]

/* -----------------------------------------------------------------------------
   Closures
   -------------------------------------------------------------------------- */

/* The offset of the payload of an array */
#define BYTE_ARR_CTS(arr)  ((arr) + SIZEOF_StgArrBytes)

/* The number of words allocated in an array payload */
#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr))

/* Getting/setting the info pointer of a closure */
#define SET_INFO(p,info) StgHeader_info(p) = info
#define GET_INFO(p) StgHeader_info(p)

/* Determine the size of an ordinary closure from its info table */
#define sizeW_fromITBL(itbl) \
  SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))

/* NB. duplicated from InfoTables.h! */
#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)

/* Debugging macros */
#define LOOKS_LIKE_INFO_PTR(p)                                  \
   ((p) != NULL &&                                              \
    LOOKS_LIKE_INFO_PTR_NOT_NULL(p))

#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p)                         \
   ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&     \
     (TO_W_(%INFO_TYPE(%STD_INFO(p))) <  N_CLOSURE_TYPES))

#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))

/*
 * The layout of the StgFunInfoExtra part of an info table changes
 * depending on TABLES_NEXT_TO_CODE.  So we define field access
 * macros which use the appropriate version here:
 */
#if defined(TABLES_NEXT_TO_CODE)
/*
 * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset
 * instead of the normal pointer.
 */

#define StgFunInfoExtra_slow_apply(fun_info)    \
        (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info))    \
               + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)

#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraRev_fun_type(i)
#define StgFunInfoExtra_arity(i)      StgFunInfoExtraRev_arity(i)
#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraRev_bitmap(i)
#else
#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)
#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraFwd_fun_type(i)
#define StgFunInfoExtra_arity(i)      StgFunInfoExtraFwd_arity(i)
#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
#endif

#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))

#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size)
#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n)
#else
#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */
#define OVERWRITING_CLOSURE(c) /* nothing */
#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
#endif

#if defined(THREADED_RTS)
#define prim_write_barrier prim %write_barrier()
#else
#define prim_write_barrier /* nothing */
#endif

/* -----------------------------------------------------------------------------
   Ticky macros
   -------------------------------------------------------------------------- */

#if defined(TICKY_TICKY)
#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n
#else
#define TICK_BUMP_BY(ctr,n) /* nothing */
#endif

#define TICK_BUMP(ctr)      TICK_BUMP_BY(ctr,1)

#define TICK_ENT_DYN_IND()              TICK_BUMP(ENT_DYN_IND_ctr)
#define TICK_ENT_DYN_THK()              TICK_BUMP(ENT_DYN_THK_ctr)
#define TICK_ENT_VIA_NODE()             TICK_BUMP(ENT_VIA_NODE_ctr)
#define TICK_ENT_STATIC_IND()           TICK_BUMP(ENT_STATIC_IND_ctr)
#define TICK_ENT_PERM_IND()             TICK_BUMP(ENT_PERM_IND_ctr)
#define TICK_ENT_PAP()                  TICK_BUMP(ENT_PAP_ctr)
#define TICK_ENT_AP()                   TICK_BUMP(ENT_AP_ctr)
#define TICK_ENT_AP_STACK()             TICK_BUMP(ENT_AP_STACK_ctr)
#define TICK_ENT_BH()                   TICK_BUMP(ENT_BH_ctr)
#define TICK_ENT_LNE()                  TICK_BUMP(ENT_LNE_ctr)
#define TICK_UNKNOWN_CALL()             TICK_BUMP(UNKNOWN_CALL_ctr)
#define TICK_UPDF_PUSHED()              TICK_BUMP(UPDF_PUSHED_ctr)
#define TICK_CATCHF_PUSHED()            TICK_BUMP(CATCHF_PUSHED_ctr)
#define TICK_UPDF_OMITTED()             TICK_BUMP(UPDF_OMITTED_ctr)
#define TICK_UPD_NEW_IND()              TICK_BUMP(UPD_NEW_IND_ctr)
#define TICK_UPD_NEW_PERM_IND()         TICK_BUMP(UPD_NEW_PERM_IND_ctr)
#define TICK_UPD_OLD_IND()              TICK_BUMP(UPD_OLD_IND_ctr)
#define TICK_UPD_OLD_PERM_IND()         TICK_BUMP(UPD_OLD_PERM_IND_ctr)

#define TICK_SLOW_CALL_FUN_TOO_FEW()    TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)
#define TICK_SLOW_CALL_FUN_CORRECT()    TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)
#define TICK_SLOW_CALL_FUN_TOO_MANY()   TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)
#define TICK_SLOW_CALL_PAP_TOO_FEW()    TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)
#define TICK_SLOW_CALL_PAP_CORRECT()    TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)
#define TICK_SLOW_CALL_PAP_TOO_MANY()   TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)

#define TICK_SLOW_CALL_fast_v16()       TICK_BUMP(SLOW_CALL_fast_v16_ctr)
#define TICK_SLOW_CALL_fast_v()         TICK_BUMP(SLOW_CALL_fast_v_ctr)
#define TICK_SLOW_CALL_fast_p()         TICK_BUMP(SLOW_CALL_fast_p_ctr)
#define TICK_SLOW_CALL_fast_pv()        TICK_BUMP(SLOW_CALL_fast_pv_ctr)
#define TICK_SLOW_CALL_fast_pp()        TICK_BUMP(SLOW_CALL_fast_pp_ctr)
#define TICK_SLOW_CALL_fast_ppv()       TICK_BUMP(SLOW_CALL_fast_ppv_ctr)
#define TICK_SLOW_CALL_fast_ppp()       TICK_BUMP(SLOW_CALL_fast_ppp_ctr)
#define TICK_SLOW_CALL_fast_pppv()      TICK_BUMP(SLOW_CALL_fast_pppv_ctr)
#define TICK_SLOW_CALL_fast_pppp()      TICK_BUMP(SLOW_CALL_fast_pppp_ctr)
#define TICK_SLOW_CALL_fast_ppppp()     TICK_BUMP(SLOW_CALL_fast_ppppp_ctr)
#define TICK_SLOW_CALL_fast_pppppp()    TICK_BUMP(SLOW_CALL_fast_pppppp_ctr)
#define TICK_VERY_SLOW_CALL()           TICK_BUMP(VERY_SLOW_CALL_ctr)

/* NOTE: TICK_HISTO_BY and TICK_HISTO
   currently have no effect.
   The old code for it didn't typecheck and I
   just commented it out to get ticky to work.
   - krc 1/2007 */

#define TICK_HISTO_BY(histo,n,i) /* nothing */

#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)

/* An unboxed tuple with n components. */
#define TICK_RET_UNBOXED_TUP(n)                 \
  TICK_BUMP(RET_UNBOXED_TUP_ctr++);             \
  TICK_HISTO(RET_UNBOXED_TUP,n)

/*
 * A slow call with n arguments.  In the unevald case, this call has
 * already been counted once, so don't count it again.
 */
#define TICK_SLOW_CALL(n)                       \
  TICK_BUMP(SLOW_CALL_ctr);                     \
  TICK_HISTO(SLOW_CALL,n)

/*
 * This slow call was found to be to an unevaluated function; undo the
 * ticks we did in TICK_SLOW_CALL.
 */
#define TICK_SLOW_CALL_UNEVALD(n)               \
  TICK_BUMP(SLOW_CALL_UNEVALD_ctr);             \
  TICK_BUMP_BY(SLOW_CALL_ctr,-1);               \
  TICK_HISTO_BY(SLOW_CALL,n,-1);

/* Updating a closure with a new CON */
#define TICK_UPD_CON_IN_NEW(n)                  \
  TICK_BUMP(UPD_CON_IN_NEW_ctr);                \
  TICK_HISTO(UPD_CON_IN_NEW,n)

#define TICK_ALLOC_HEAP_NOCTR(bytes)            \
    TICK_BUMP(ALLOC_RTS_ctr);                   \
    TICK_BUMP_BY(ALLOC_RTS_tot,bytes)

/* -----------------------------------------------------------------------------
   Saving and restoring STG registers

   STG registers must be saved around a C call, just in case the STG
   register is mapped to a caller-saves machine register.  Normally we
   don't need to worry about this the code generator has already
   loaded any live STG registers into variables for us, but in
   hand-written low-level Cmm code where we don't know which registers
   are live, we might have to save them all.
   -------------------------------------------------------------------------- */

#define SAVE_STGREGS                            \
    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \
    F_ f1, f2, f3, f4, f5, f6;                  \
    D_ d1, d2, d3, d4, d5, d6;                  \
    L_ l1;                                      \
                                                \
    r1 = R1;                                    \
    r2 = R2;                                    \
    r3 = R3;                                    \
    r4 = R4;                                    \
    r5 = R5;                                    \
    r6 = R6;                                    \
    r7 = R7;                                    \
    r8 = R8;                                    \
                                                \
    f1 = F1;                                    \
    f2 = F2;                                    \
    f3 = F3;                                    \
    f4 = F4;                                    \
    f5 = F5;                                    \
    f6 = F6;                                    \
                                                \
    d1 = D1;                                    \
    d2 = D2;                                    \
    d3 = D3;                                    \
    d4 = D4;                                    \
    d5 = D5;                                    \
    d6 = D6;                                    \
                                                \
    l1 = L1;


#define RESTORE_STGREGS                         \
    R1 = r1;                                    \
    R2 = r2;                                    \
    R3 = r3;                                    \
    R4 = r4;                                    \
    R5 = r5;                                    \
    R6 = r6;                                    \
    R7 = r7;                                    \
    R8 = r8;                                    \
                                                \
    F1 = f1;                                    \
    F2 = f2;                                    \
    F3 = f3;                                    \
    F4 = f4;                                    \
    F5 = f5;                                    \
    F6 = f6;                                    \
                                                \
    D1 = d1;                                    \
    D2 = d2;                                    \
    D3 = d3;                                    \
    D4 = d4;                                    \
    D5 = d5;                                    \
    D6 = d6;                                    \
                                                \
    L1 = l1;

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

#define NO_TREC                   stg_NO_TREC_closure
#define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
#define STM_AWOKEN                stg_STM_AWOKEN_closure

#define recordMutableCap(p, gen)                                        \
  W_ __bd;                                                              \
  W_ mut_list;                                                          \
  mut_list = Capability_mut_lists(MyCapability()) + WDS(gen);           \
 __bd = W_[mut_list];                                                   \
  if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {           \
      W_ __new_bd;                                                      \
      ("ptr" __new_bd) = foreign "C" allocBlock_lock();                 \
      bdescr_link(__new_bd) = __bd;                                     \
      __bd = __new_bd;                                                  \
      W_[mut_list] = __bd;                                              \
  }                                                                     \
  W_ free;                                                              \
  free = bdescr_free(__bd);                                             \
  W_[free] = p;                                                         \
  bdescr_free(__bd) = free + WDS(1);

#define recordMutable(p)                                        \
      P_ __p;                                                   \
      W_ __bd;                                                  \
      W_ __gen;                                                 \
      __p = p;                                                  \
      __bd = Bdescr(__p);                                       \
      __gen = TO_W_(bdescr_gen_no(__bd));                       \
      if (__gen > 0) { recordMutableCap(__p, __gen); }

/* -----------------------------------------------------------------------------
   Arrays
   -------------------------------------------------------------------------- */

/* Complete function body for the clone family of (mutable) array ops.
   Defined as a macro to avoid function call overhead or code
   duplication. */
#define cloneArray(info, src, offset, n)                       \
    W_ words, size;                                            \
    gcptr dst, dst_p, src_p;                                   \
                                                               \
    again: MAYBE_GC(again);                                    \
                                                               \
    size = n + mutArrPtrsCardWords(n);                         \
    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;         \
    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);       \
                                                               \
    SET_HDR(dst, info, CCCS);                                  \
    StgMutArrPtrs_ptrs(dst) = n;                               \
    StgMutArrPtrs_size(dst) = size;                            \
                                                               \
    dst_p = dst + SIZEOF_StgMutArrPtrs;                        \
    src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset);          \
    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
                                                               \
    return (dst);

#define copyArray(src, src_off, dst, dst_off, n)                  \
  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
                                                                  \
    if ((n) != 0) {                                               \
        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
                                                                  \
        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
        dst_p = dst_elems_p + WDS(dst_off);                       \
        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
        bytes = WDS(n);                                           \
                                                                  \
        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);              \
                                                                  \
        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
        setCards(dst_cards_p, dst_off, n);                        \
    }                                                             \
                                                                  \
    return ();

#define copyMutableArray(src, src_off, dst, dst_off, n)           \
  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
                                                                  \
    if ((n) != 0) {                                               \
        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
                                                                  \
        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
        dst_p = dst_elems_p + WDS(dst_off);                       \
        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
        bytes = WDS(n);                                           \
                                                                  \
        if ((src) == (dst)) {                                     \
            prim %memmove(dst_p, src_p, bytes, SIZEOF_W);         \
        } else {                                                  \
            prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);          \
        }                                                         \
                                                                  \
        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
        setCards(dst_cards_p, dst_off, n);                        \
    }                                                             \
                                                                  \
    return ();

/*
 * Set the cards in the cards table pointed to by dst_cards_p for an
 * update to n elements, starting at element dst_off.
 */
#define setCards(dst_cards_p, dst_off, n)                      \
    W_ __start_card, __end_card, __cards;                      \
    __start_card = mutArrPtrCardDown(dst_off);                 \
    __end_card = mutArrPtrCardDown((dst_off) + (n) - 1);       \
    __cards = __end_card - __start_card + 1;                   \
    prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);

/* Complete function body for the clone family of small (mutable)
   array ops. Defined as a macro to avoid function call overhead or
   code duplication. */
#define cloneSmallArray(info, src, offset, n)                  \
    W_ words, size;                                            \
    gcptr dst, dst_p, src_p;                                   \
                                                               \
    again: MAYBE_GC(again);                                    \
                                                               \
    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;       \
    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);     \
                                                               \
    SET_HDR(dst, info, CCCS);                                  \
    StgSmallMutArrPtrs_ptrs(dst) = n;                          \
                                                               \
    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;                   \
    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset);     \
    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
                                                               \
    return (dst);