    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE MultiWayIf #-}

    -----------------------------------------------------------------------------
    --
    -- Code generation for ticky-ticky profiling
    --
    -- (c) The University of Glasgow 2004-2006
    --
    -----------------------------------------------------------------------------

    {- OVERVIEW: ticky ticky profiling

    Please see
    https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also
    edit it and the rest of this comment to keep them up-to-date if you
    change ticky-ticky. Thanks!

     *** All allocation ticky numbers are in bytes. ***

    Some of the relevant source files:

           ***not necessarily an exhaustive list***

      * some codeGen/ modules import this one

      * this module imports GHC.Cmm.CLabel to manage labels

      * GHC.Cmm.Parser expands some macros using generators defined in
        this module

      * includes/stg/Ticky.h declares all of the global counters

      * includes/rts/Ticky.h declares the C data type for an
        STG-declaration's counters

      * some macros defined in includes/Cmm.h (and used within the RTS's
        CMM code) update the global ticky counters

      * at the end of execution rts/Ticky.c generates the final report
        +RTS -r<report-file> -RTS

    The rts/Ticky.c function that generates the report includes an
    STG-declaration's ticky counters if

      * that declaration was entered, or

      * it was allocated (if -ticky-allocd)

    On either of those events, the counter is "registered" by adding it to
    a linked list; cf the CMM generated by registerTickyCtr.

    Ticky-ticky profiling has evolved over many years. Many of the
    counters from its most sophisticated days are no longer
    active/accurate. As the RTS has changed, sometimes the ticky code for
    relevant counters was not accordingly updated. Unfortunately, neither
    were the comments.

    As of March 2013, there still exist deprecated code and comments in
    the code generator as well as the RTS because:

      * I don't know what is out-of-date versus merely commented out for
        momentary convenience, and

      * someone else might know how to repair it!

    -}

    module GHC.StgToCmm.Ticky (
      withNewTickyCounterFun,
      withNewTickyCounterLNE,
      withNewTickyCounterThunk,
      withNewTickyCounterStdThunk,
      withNewTickyCounterCon,

      tickyDynAlloc,
      tickyAllocHeap,

      tickyAllocPrim,
      tickyAllocThunk,
      tickyAllocPAP,
      tickyHeapCheck,
      tickyStackCheck,

      tickyDirectCall,

      tickyPushUpdateFrame,
      tickyUpdateFrameOmitted,

      tickyEnterDynCon,

      tickyEnterFun,
      tickyEnterThunk,
      tickyEnterLNE,

      tickyUpdateBhCaf,
      tickyUnboxedTupleReturn,
      tickyReturnOldCon, tickyReturnNewCon,

      tickySlowCall
      ) where

    import GHC.Prelude

    import GHC.Platform
    import GHC.Platform.Profile

    import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )
    import GHC.StgToCmm.Closure
    import GHC.StgToCmm.Utils
    import GHC.StgToCmm.Monad
    import {-# SOURCE #-} GHC.StgToCmm.Foreign   ( emitPrimCall )

    import GHC.Stg.Syntax
    import GHC.Cmm.Expr
    import GHC.Cmm.Graph
    import GHC.Cmm.Utils
    import GHC.Cmm.CLabel
    import GHC.Runtime.Heap.Layout

    import GHC.Types.Name
    import GHC.Types.Id
    import GHC.Types.Basic
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Misc

    import GHC.Driver.Session
    import GHC.Driver.Ppr

    -- Turgid imports for showTypeCategory
    import GHC.Builtin.Names
    import GHC.Tc.Utils.TcType
    import GHC.Core.DataCon
    import GHC.Core.TyCon
    import GHC.Core.Predicate

    import Data.Maybe
    import qualified Data.Char
    import Control.Monad ( when )

    -----------------------------------------------------------------------------
    --
    -- Ticky-ticky profiling
    --
    -----------------------------------------------------------------------------

    data TickyClosureType
        = TickyFun
            Bool -- True <-> single entry
        | TickyCon
            DataCon -- the allocated constructor
        | TickyThunk
            Bool -- True <-> updateable
            Bool -- True <-> standard thunk (AP or selector), has no entry counter
        | TickyLNE

    withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounterFun :: forall a. Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounterFun Bool
    single_entry = forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter (Bool -> TickyClosureType
    TickyFun Bool
    single_entry)

    withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounterLNE :: forall a. Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounterLNE Name
    nm [NonVoid Id]
    args FCode a
    code = do
      Bool
    b <- FCode Bool
    tickyLNEIsOn
      if Bool -> Bool
    not Bool
    b then FCode a
    code else forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter TickyClosureType
    TickyLNE Name
    nm [NonVoid Id]
    args FCode a
    code

    thunkHasCounter :: Bool -> FCode Bool
    thunkHasCounter :: Bool -> FCode Bool
    thunkHasCounter Bool
    isStatic = do
      Bool
    b <- FCode Bool
    tickyDynThunkIsOn
      forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Bool -> Bool
    not Bool
    isStatic Bool -> Bool -> Bool
    && Bool
    b)

    withNewTickyCounterThunk
      :: Bool -- ^ static
      -> Bool -- ^ updateable
      -> Name
      -> FCode a
      -> FCode a
    withNewTickyCounterThunk :: forall a. Bool -> Bool -> Name -> FCode a -> FCode a
    withNewTickyCounterThunk Bool
    isStatic Bool
    isUpdatable Name
    name FCode a
    code = do
        Bool
    has_ctr <- Bool -> FCode Bool
    thunkHasCounter Bool
    isStatic
        if Bool -> Bool
    not Bool
    has_ctr
          then FCode a
    code
          else forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter (Bool -> Bool -> TickyClosureType
    TickyThunk Bool
    isUpdatable Bool
    False) Name
    name [] FCode a
    code

    withNewTickyCounterStdThunk
      :: Bool -- ^ updateable
      -> Name
      -> FCode a
      -> FCode a
    withNewTickyCounterStdThunk :: forall a. Bool -> Name -> FCode a -> FCode a
    withNewTickyCounterStdThunk Bool
    isUpdatable Name
    name FCode a
    code = do
        Bool
    has_ctr <- Bool -> FCode Bool
    thunkHasCounter Bool
    False
        if Bool -> Bool
    not Bool
    has_ctr
          then FCode a
    code
          else forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter (Bool -> Bool -> TickyClosureType
    TickyThunk Bool
    isUpdatable Bool
    True) Name
    name [] FCode a
    code

    withNewTickyCounterCon
      :: Name
      -> DataCon
      -> FCode a
      -> FCode a
    withNewTickyCounterCon :: forall a. Name -> DataCon -> FCode a -> FCode a
    withNewTickyCounterCon Name
    name DataCon
    datacon FCode a
    code = do
        Bool
    has_ctr <- Bool -> FCode Bool
    thunkHasCounter Bool
    False
        if Bool -> Bool
    not Bool
    has_ctr
          then FCode a
    code
          else forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter (DataCon -> TickyClosureType
    TickyCon DataCon
    datacon) Name
    name [] FCode a
    code

    -- args does not include the void arguments
    withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter :: forall a.
    TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
    withNewTickyCounter TickyClosureType
    cloType Name
    name [NonVoid Id]
    args FCode a
    m = do
      CLabel
    lbl <- TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
    emitTickyCounter TickyClosureType
    cloType Name
    name [NonVoid Id]
    args
      forall a. CLabel -> FCode a -> FCode a
    setTickyCtrLabel CLabel
    lbl FCode a
    m

    emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
    emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
    emitTickyCounter TickyClosureType
    cloType Name
    name [NonVoid Id]
    args
      = let ctr_lbl :: CLabel
    ctr_lbl = Name -> CLabel
    mkRednCountsLabel Name
    name in
        (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> forall (m :: * -> *) a. Monad m => a -> m a
    return CLabel
    ctr_lbl) forall a b. (a -> b) -> a -> b
    $
        FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
            { DynFlags
    dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
            ; Platform
    platform <- FCode Platform
    getPlatform
            ; CLabel
    parent <- FCode CLabel
    getTickyCtrLabel
            ; Module
    mod_name <- FCode Module
    getModuleName

              -- When printing the name of a thing in a ticky file, we
              -- want to give the module name even for *local* things.  We
              -- print just "x (M)" rather that "M.x" to distinguish them
              -- from the global kind.
            ; let ppr_for_ticky_name :: SDoc
                  ppr_for_ticky_name :: SDoc
    ppr_for_ticky_name =
                    let n :: SDoc
    n = forall a. Outputable a => a -> SDoc
    ppr Name
    name
                        ext :: SDoc
    ext = case TickyClosureType
    cloType of
                                  TickyFun Bool
    single_entry -> SDoc -> SDoc
    parens forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    hcat forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma forall a b. (a -> b) -> a -> b
    $
                                      [String -> SDoc
    text String
    "fun"] forall a. [a] -> [a] -> [a]
    ++ [String -> SDoc
    text String
    "se"|Bool
    single_entry]
                                  TickyCon DataCon
    datacon -> SDoc -> SDoc
    parens (String -> SDoc
    text String
    "con:" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (DataCon -> Name
    dataConName DataCon
    datacon))
                                  TickyThunk Bool
    upd Bool
    std -> SDoc -> SDoc
    parens forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    hcat forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma forall a b. (a -> b) -> a -> b
    $
                                      [String -> SDoc
    text String
    "thk"] forall a. [a] -> [a] -> [a]
    ++ [String -> SDoc
    text String
    "se"|Bool -> Bool
    not Bool
    upd] forall a. [a] -> [a] -> [a]
    ++ [String -> SDoc
    text String
    "std"|Bool
    std]
                                  TickyClosureType
    TickyLNE | Name -> Bool
    isInternalName Name
    name -> SDoc -> SDoc
    parens (String -> SDoc
    text String
    "LNE")
                                           | Bool
    otherwise -> forall a. String -> a
    panic String
    "emitTickyCounter: how is this an external LNE?"
                        p :: SDoc
    p = case CLabel -> Maybe Name
    hasHaskellName CLabel
    parent of
                                -- NB the default "top" ticky ctr does not
                                -- have a Haskell name
                              Just Name
    pname -> String -> SDoc
    text String
    "in" SDoc -> SDoc -> SDoc
    <+> forall a. Outputable a => a -> SDoc
    ppr (Name -> Unique
    nameUnique Name
    pname)
                              Maybe Name
    _ -> SDoc
    empty
                    in if Name -> Bool
    isInternalName Name
    name
                       then SDoc
    n SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    parens (forall a. Outputable a => a -> SDoc
    ppr Module
    mod_name) SDoc -> SDoc -> SDoc
    <+> SDoc
    ext SDoc -> SDoc -> SDoc
    <+> SDoc
    p
                       else SDoc
    n SDoc -> SDoc -> SDoc
    <+> SDoc
    ext SDoc -> SDoc -> SDoc
    <+> SDoc
    p

            ; CmmLit
    fun_descr_lit <- String -> FCode CmmLit
    newStringCLit forall a b. (a -> b) -> a -> b
    $ DynFlags -> SDoc -> String
    showSDocDebug DynFlags
    dflags SDoc
    ppr_for_ticky_name
            ; CmmLit
    arg_descr_lit <- String -> FCode CmmLit
    newStringCLit forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map (Type -> Char
    showTypeCategory forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> Type
    idType forall b c a. (b -> c) -> (a -> b) -> a -> c
    . forall a. NonVoid a -> a
    fromNonVoid) [NonVoid Id]
    args
            ; CLabel -> [CmmLit] -> FCode ()
    emitDataLits CLabel
    ctr_lbl
            -- Must match layout of includes/rts/Ticky.h's StgEntCounter
            --
            -- krc: note that all the fields are I32 now; some were I16
            -- before, but the code generator wasn't handling that
            -- properly and it led to chaos, panic and disorder.
                [ Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0,               -- registered?
                  Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [NonVoid Id]
    args),   -- Arity
                  Platform -> Int -> CmmLit
    mkIntCLit Platform
    platform Int
    0,               -- Heap allocated for this thing
                  CmmLit
    fun_descr_lit,
                  CmmLit
    arg_descr_lit,
                  Platform -> CmmLit
    zeroCLit Platform
    platform,          -- Entries into this thing
                  Platform -> CmmLit
    zeroCLit Platform
    platform,          -- Heap allocated by this thing
                  Platform -> CmmLit
    zeroCLit Platform
    platform           -- Link to next StgEntCounter
                ]
            }

    -- -----------------------------------------------------------------------------
    -- Ticky stack frames

    tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
    tickyPushUpdateFrame :: FCode ()
    tickyPushUpdateFrame    = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "UPDF_PUSHED_ctr")
    tickyUpdateFrameOmitted :: FCode ()
    tickyUpdateFrameOmitted = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "UPDF_OMITTED_ctr")

    -- -----------------------------------------------------------------------------
    -- Ticky entries

    -- NB the name-specific entries are only available for names that have
    -- dedicated Cmm code. As far as I know, this just rules out
    -- constructor thunks. For them, there is no CMM code block to put the
    -- bump of name-specific ticky counter into. On the other hand, we can
    -- still track allocation their allocation.

    tickyEnterDynCon :: FCode ()
    tickyEnterDynCon :: FCode ()
    tickyEnterDynCon = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "ENT_DYN_CON_ctr")

    tickyEnterThunk :: ClosureInfo -> FCode ()
    tickyEnterThunk :: ClosureInfo -> FCode ()
    tickyEnterThunk ClosureInfo
    cl_info
      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
        { FastString -> FCode ()
    bumpTickyCounter FastString
    ctr
        ; Bool
    has_ctr <- Bool -> FCode Bool
    thunkHasCounter Bool
    static
        ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    has_ctr forall a b. (a -> b) -> a -> b
    $ do
          CLabel
    ticky_ctr_lbl <- FCode CLabel
    getTickyCtrLabel
          CLabel -> FCode ()
    registerTickyCtrAtEntryDyn CLabel
    ticky_ctr_lbl
          CLabel -> FCode ()
    bumpTickyEntryCount CLabel
    ticky_ctr_lbl }
      where
        updatable :: Bool
    updatable = Bool -> Bool
    not (ClosureInfo -> Bool
    closureUpdReqd ClosureInfo
    cl_info)
        static :: Bool
    static    = ClosureInfo -> Bool
    isStaticClosure ClosureInfo
    cl_info

        ctr :: FastString
    ctr | Bool
    static    = if Bool
    updatable then String -> FastString
    fsLit String
    "ENT_STATIC_THK_SINGLE_ctr"
                                       else String -> FastString
    fsLit String
    "ENT_STATIC_THK_MANY_ctr"
            | Bool
    otherwise = if Bool
    updatable then String -> FastString
    fsLit String
    "ENT_DYN_THK_SINGLE_ctr"
                                       else String -> FastString
    fsLit String
    "ENT_DYN_THK_MANY_ctr"

    tickyUpdateBhCaf :: ClosureInfo -> FCode ()
    tickyUpdateBhCaf :: ClosureInfo -> FCode ()
    tickyUpdateBhCaf ClosureInfo
    cl_info
      = FCode () -> FCode ()
    ifTicky (FastString -> FCode ()
    bumpTickyCounter FastString
    ctr)
      where
        ctr :: FastString
    ctr | ClosureInfo -> Bool
    closureUpdReqd ClosureInfo
    cl_info = (String -> FastString
    fsLit String
    "UPD_CAF_BH_SINGLE_ENTRY_ctr")
            | Bool
    otherwise              = (String -> FastString
    fsLit String
    "UPD_CAF_BH_UPDATABLE_ctr")

    tickyEnterFun :: ClosureInfo -> FCode ()
    tickyEnterFun :: ClosureInfo -> FCode ()
    tickyEnterFun ClosureInfo
    cl_info = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      CLabel
    ctr_lbl <- FCode CLabel
    getTickyCtrLabel

      if ClosureInfo -> Bool
    isStaticClosure ClosureInfo
    cl_info
        then do FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "ENT_STATIC_FUN_DIRECT_ctr")
                CLabel -> FCode ()
    registerTickyCtr CLabel
    ctr_lbl
        else do FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "ENT_DYN_FUN_DIRECT_ctr")
                CLabel -> FCode ()
    registerTickyCtrAtEntryDyn CLabel
    ctr_lbl

      CLabel -> FCode ()
    bumpTickyEntryCount CLabel
    ctr_lbl

    tickyEnterLNE :: FCode ()
    tickyEnterLNE :: FCode ()
    tickyEnterLNE = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "ENT_LNE_ctr")
      FCode () -> FCode ()
    ifTickyLNE forall a b. (a -> b) -> a -> b
    $ do
        CLabel
    ctr_lbl <- FCode CLabel
    getTickyCtrLabel
        CLabel -> FCode ()
    registerTickyCtr CLabel
    ctr_lbl
        CLabel -> FCode ()
    bumpTickyEntryCount CLabel
    ctr_lbl

    -- needn't register a counter upon entry if
    --
    -- 1) it's for a dynamic closure, and
    --
    -- 2) -ticky-allocd is on
    --
    -- since the counter was registered already upon being alloc'd
    registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
    registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
    registerTickyCtrAtEntryDyn CLabel
    ctr_lbl = do
      Bool
    already_registered <- FCode Bool
    tickyAllocdIsOn
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool -> Bool
    not Bool
    already_registered) forall a b. (a -> b) -> a -> b
    $ CLabel -> FCode ()
    registerTickyCtr CLabel
    ctr_lbl

    -- | Register a ticky counter.
    --
    -- It's important that this does not race with other entries of the same
    -- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also
    -- need to make sure that this is reasonably efficient. Consequently, we first
    -- perform a normal load of the counter's "registered" flag to check whether
    -- registration is necessary. If so, then we do a compare-and-swap to lock the
    -- counter for registration and use an atomic-exchange to add the counter to the list.
    --
    -- @
    -- if ( f_ct.registeredp == 0 ) {
    --    if (cas(f_ct.registeredp, 0, 1) == 0) {
    --        old_head = xchg(ticky_entry_ctrs,  f_ct);
    --        f_ct.link = old_head;
    --    }
    -- }
    -- @
    registerTickyCtr :: CLabel -> FCode ()
    registerTickyCtr :: CLabel -> FCode ()
    registerTickyCtr CLabel
    ctr_lbl = do
      Platform
    platform <- FCode Platform
    getPlatform
      let constants :: PlatformConstants
    constants = Platform -> PlatformConstants
    platformConstants Platform
    platform
          word_width :: Width
    word_width = Platform -> Width
    wordWidth Platform
    platform
          registeredp :: CmmExpr
    registeredp = CmmLit -> CmmExpr
    CmmLit (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    ctr_lbl (PlatformConstants -> Int
    pc_OFFSET_StgEntCounter_registeredp PlatformConstants
    constants))

      CmmAGraph
    register_stmts <- forall a. FCode a -> FCode CmmAGraph
    getCode forall a b. (a -> b) -> a -> b
    $ do
        LocalReg
    old_head <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
        let ticky_entry_ctrs :: CmmExpr
    ticky_entry_ctrs = CLabel -> CmmExpr
    mkLblExpr (FastString -> CLabel
    mkRtsCmmDataLabel (String -> FastString
    fsLit String
    "ticky_entry_ctrs"))
            link :: CmmExpr
    link = CmmLit -> CmmExpr
    CmmLit (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    ctr_lbl (PlatformConstants -> Int
    pc_OFFSET_StgEntCounter_link PlatformConstants
    constants))
        [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
    emitPrimCall [LocalReg
    old_head] (Width -> CallishMachOp
    MO_Xchg Width
    word_width) [CmmExpr
    ticky_entry_ctrs, CLabel -> CmmExpr
    mkLblExpr CLabel
    ctr_lbl]
        CmmExpr -> CmmExpr -> FCode ()
    emitStore CmmExpr
    link (CmmReg -> CmmExpr
    CmmReg forall a b. (a -> b) -> a -> b
    $ LocalReg -> CmmReg
    CmmLocal LocalReg
    old_head)

      CmmAGraph
    cas_test <- forall a. FCode a -> FCode CmmAGraph
    getCode forall a b. (a -> b) -> a -> b
    $ do
        LocalReg
    old <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
    newTemp (Platform -> CmmType
    bWord Platform
    platform)
        [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
    emitPrimCall [LocalReg
    old] (Width -> CallishMachOp
    MO_Cmpxchg Width
    word_width)
            [CmmExpr
    registeredp, Platform -> CmmExpr
    zeroExpr Platform
    platform, Platform -> Int -> CmmExpr
    mkIntExpr Platform
    platform Int
    1]
        let locked :: CmmExpr
    locked = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmEqWord Platform
    platform (CmmReg -> CmmExpr
    CmmReg forall a b. (a -> b) -> a -> b
    $ LocalReg -> CmmReg
    CmmLocal LocalReg
    old) (Platform -> CmmExpr
    zeroExpr Platform
    platform)
        CmmAGraph -> FCode ()
    emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
    mkCmmIfThen CmmExpr
    locked CmmAGraph
    register_stmts

      let test :: CmmExpr
    test = Platform -> CmmExpr -> CmmExpr -> CmmExpr
    cmmEqWord Platform
    platform (Platform -> CmmExpr -> CmmExpr
    cmmLoadBWord Platform
    platform CmmExpr
    registeredp) (Platform -> CmmExpr
    zeroExpr Platform
    platform)
      CmmAGraph -> FCode ()
    emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
    mkCmmIfThen CmmExpr
    test CmmAGraph
    cas_test

    tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
    tickyReturnOldCon :: Int -> FCode ()
    tickyReturnOldCon Int
    arity
      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do { FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "RET_OLD_ctr")
                     ; FastString -> Int -> FCode ()
    bumpHistogram    (String -> FastString
    fsLit String
    "RET_OLD_hst") Int
    arity }
    tickyReturnNewCon :: Int -> FCode ()
    tickyReturnNewCon Int
    arity
      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do { FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "RET_NEW_ctr")
                     ; FastString -> Int -> FCode ()
    bumpHistogram    (String -> FastString
    fsLit String
    "RET_NEW_hst") Int
    arity }

    tickyUnboxedTupleReturn :: RepArity -> FCode ()
    tickyUnboxedTupleReturn :: Int -> FCode ()
    tickyUnboxedTupleReturn Int
    arity
      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do { FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "RET_UNBOXED_TUP_ctr")
                     ; FastString -> Int -> FCode ()
    bumpHistogram    (String -> FastString
    fsLit String
    "RET_UNBOXED_TUP_hst") Int
    arity }

    -- -----------------------------------------------------------------------------
    -- Ticky calls

    -- Ticks at a *call site*:
    tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
    tickyDirectCall :: Int -> [StgArg] -> FCode ()
    tickyDirectCall Int
    arity [StgArg]
    args
      | [StgArg]
    args forall a. [a] -> Int -> Bool
    `lengthIs` Int
    arity = FCode ()
    tickyKnownCallExact
      | Bool
    otherwise = do FCode ()
    tickyKnownCallExtraArgs
                       [PrimRep] -> FCode ()
    tickySlowCallPat (forall a b. (a -> b) -> [a] -> [b]
    map StgArg -> PrimRep
    argPrimRep (forall a. Int -> [a] -> [a]
    drop Int
    arity [StgArg]
    args))

    tickyKnownCallTooFewArgs :: FCode ()
    tickyKnownCallTooFewArgs :: FCode ()
    tickyKnownCallTooFewArgs = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "KNOWN_CALL_TOO_FEW_ARGS_ctr")

    tickyKnownCallExact :: FCode ()
    tickyKnownCallExact :: FCode ()
    tickyKnownCallExact      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "KNOWN_CALL_ctr")

    tickyKnownCallExtraArgs :: FCode ()
    tickyKnownCallExtraArgs :: FCode ()
    tickyKnownCallExtraArgs  = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "KNOWN_CALL_EXTRA_ARGS_ctr")

    tickyUnknownCall :: FCode ()
    tickyUnknownCall :: FCode ()
    tickyUnknownCall         = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "UNKNOWN_CALL_ctr")

    -- Tick for the call pattern at slow call site (i.e. in addition to
    -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
    tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
    tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
    tickySlowCall LambdaFormInfo
    _ [] = forall (m :: * -> *) a. Monad m => a -> m a
    return ()
    tickySlowCall LambdaFormInfo
    lf_info [StgArg]
    args = do
     -- see Note [Ticky for slow calls]
     if LambdaFormInfo -> Bool
    isKnownFun LambdaFormInfo
    lf_info
       then FCode ()
    tickyKnownCallTooFewArgs
       else FCode ()
    tickyUnknownCall
     [PrimRep] -> FCode ()
    tickySlowCallPat (forall a b. (a -> b) -> [a] -> [b]
    map StgArg -> PrimRep
    argPrimRep [StgArg]
    args)

    tickySlowCallPat :: [PrimRep] -> FCode ()
    tickySlowCallPat :: [PrimRep] -> FCode ()
    tickySlowCallPat [PrimRep]
    args = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      Platform
    platform <- Profile -> Platform
    profilePlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FCode Profile
    getProfile
      let argReps :: [ArgRep]
    argReps = forall a b. (a -> b) -> [a] -> [b]
    map (Platform -> PrimRep -> ArgRep
    toArgRep Platform
    platform) [PrimRep]
    args
          (FastString
    _, Int
    n_matched) = [ArgRep] -> (FastString, Int)
    slowCallPattern [ArgRep]
    argReps
      if Int
    n_matched forall a. Ord a => a -> a -> Bool
    > Int
    0 Bool -> Bool -> Bool
    && [PrimRep]
    args forall a. [a] -> Int -> Bool
    `lengthIs` Int
    n_matched
         then CLabel -> FCode ()
    bumpTickyLbl forall a b. (a -> b) -> a -> b
    $ String -> CLabel
    mkRtsSlowFastTickyCtrLabel forall a b. (a -> b) -> a -> b
    $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    Data.Char.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ArgRep -> String
    argRepString) [ArgRep]
    argReps
         else FastString -> FCode ()
    bumpTickyCounter forall a b. (a -> b) -> a -> b
    $ String -> FastString
    fsLit String
    "VERY_SLOW_CALL_ctr"

    {-

    Note [Ticky for slow calls]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Terminology is unfortunately a bit mixed up for these calls. codeGen
    uses "slow call" to refer to unknown calls and under-saturated known
    calls.

    Nowadays, though (ie as of the eval/apply paper), the significantly
    slower calls are actually just a subset of these: the ones with no
    built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)

    So for ticky profiling, we split slow calls into
    "SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
    VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
    bad for both space and time).

    -}

    -- -----------------------------------------------------------------------------
    -- Ticky allocation

    tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
    -- Called when doing a dynamic heap allocation; the LambdaFormInfo
    -- used to distinguish between closure types
    --
    -- TODO what else to count while we're here?
    tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
    tickyDynAlloc Maybe Id
    mb_id SMRep
    rep LambdaFormInfo
    lf = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      Profile
    profile <- FCode Profile
    getProfile
      let platform :: Platform
    platform = Profile -> Platform
    profilePlatform Profile
    profile
          bytes :: Int
    bytes = Platform -> Int
    platformWordSizeInBytes Platform
    platform forall a. Num a => a -> a -> a
    * Profile -> SMRep -> Int
    heapClosureSizeW Profile
    profile SMRep
    rep

          countGlobal :: FastString -> FastString -> FCode ()
    countGlobal FastString
    tot FastString
    ctr = do
            FastString -> Int -> FCode ()
    bumpTickyCounterBy FastString
    tot Int
    bytes
            FastString -> FCode ()
    bumpTickyCounter   FastString
    ctr
          countSpecific :: FCode ()
    countSpecific = FCode () -> FCode ()
    ifTickyAllocd forall a b. (a -> b) -> a -> b
    $ case Maybe Id
    mb_id of
            Maybe Id
    Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            Just Id
    id -> do
              let ctr_lbl :: CLabel
    ctr_lbl = Name -> CLabel
    mkRednCountsLabel (Id -> Name
    idName Id
    id)
              CLabel -> FCode ()
    registerTickyCtr CLabel
    ctr_lbl
              CLabel -> Int -> FCode ()
    bumpTickyAllocd CLabel
    ctr_lbl Int
    bytes

      -- TODO are we still tracking "good stuff" (_gds) versus
      -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
      -- for now, since I don't currently know neither if we do nor how to
      -- distinguish. NSF Mar 2013

      if | SMRep -> Bool
    isConRep SMRep
    rep   ->
             FCode () -> FCode ()
    ifTickyDynThunk FCode ()
    countSpecific forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
             FastString -> FastString -> FCode ()
    countGlobal (String -> FastString
    fsLit String
    "ALLOC_CON_gds") (String -> FastString
    fsLit String
    "ALLOC_CON_ctr")
         | SMRep -> Bool
    isThunkRep SMRep
    rep ->
             FCode () -> FCode ()
    ifTickyDynThunk FCode ()
    countSpecific forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
             if LambdaFormInfo -> Bool
    lfUpdatable LambdaFormInfo
    lf
             then FastString -> FastString -> FCode ()
    countGlobal (String -> FastString
    fsLit String
    "ALLOC_THK_gds") (String -> FastString
    fsLit String
    "ALLOC_UP_THK_ctr")
             else FastString -> FastString -> FCode ()
    countGlobal (String -> FastString
    fsLit String
    "ALLOC_THK_gds") (String -> FastString
    fsLit String
    "ALLOC_SE_THK_ctr")
         | SMRep -> Bool
    isFunRep   SMRep
    rep ->
             FCode ()
    countSpecific forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
             FastString -> FastString -> FCode ()
    countGlobal (String -> FastString
    fsLit String
    "ALLOC_FUN_gds") (String -> FastString
    fsLit String
    "ALLOC_FUN_ctr")
         | Bool
    otherwise      -> forall a. String -> a
    panic String
    "How is this heap object not a con, thunk, or fun?"

    tickyAllocHeap ::
      Bool -> -- is this a genuine allocation? As opposed to
              -- GHC.StgToCmm.Layout.adjustHpBackwards
      VirtualHpOffset -> FCode ()
    -- Called when doing a heap check [TICK_ALLOC_HEAP]
    -- Must be lazy in the amount of allocation!
    tickyAllocHeap :: Bool -> Int -> FCode ()
    tickyAllocHeap Bool
    genuine Int
    hp
      = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $
        do  { Platform
    platform <- FCode Platform
    getPlatform
            ; CLabel
    ticky_ctr <- FCode CLabel
    getTickyCtrLabel
            ; CmmAGraph -> FCode ()
    emit forall a b. (a -> b) -> a -> b
    $ [CmmAGraph] -> CmmAGraph
    catAGraphs forall a b. (a -> b) -> a -> b
    $
                -- only test hp from within the emit so that the monadic
                -- computation itself is not strict in hp (cf knot in
                -- GHC.StgToCmm.Monad.getHeapUsage)
              if Int
    hp forall a. Eq a => a -> a -> Bool
    == Int
    0 then []
              else let !bytes :: Int
    bytes = Platform -> Int
    platformWordSizeInBytes Platform
    platform forall a. Num a => a -> a -> a
    * Int
    hp in [
                -- Bump the allocation total in the closure's StgEntCounter
                CmmType -> CmmExpr -> Int -> CmmAGraph
    addToMem (Platform -> CmmType
    rEP_StgEntCounter_allocs Platform
    platform)
                         (CmmLit -> CmmExpr
    CmmLit (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    ticky_ctr (PlatformConstants -> Int
    pc_OFFSET_StgEntCounter_allocs (Platform -> PlatformConstants
    platformConstants Platform
    platform))))
                         Int
    bytes,
                -- Bump the global allocation total ALLOC_HEAP_tot
                CmmType -> CLabel -> Int -> CmmAGraph
    addToMemLbl (Platform -> CmmType
    bWord Platform
    platform)
                            (FastString -> CLabel
    mkRtsCmmDataLabel (String -> FastString
    fsLit String
    "ALLOC_HEAP_tot"))
                            Int
    bytes,
                -- Bump the global allocation counter ALLOC_HEAP_ctr
                if Bool -> Bool
    not Bool
    genuine then CmmAGraph
    mkNop
                else CmmType -> CLabel -> Int -> CmmAGraph
    addToMemLbl (Platform -> CmmType
    bWord Platform
    platform)
                                 (FastString -> CLabel
    mkRtsCmmDataLabel (String -> FastString
    fsLit String
    "ALLOC_HEAP_ctr"))
                                 Int
    1
                ]}

    --------------------------------------------------------------------------------
    -- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS)

    -- the units are bytes

    tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
                   -> CmmExpr  -- ^ size of the payload, in bytes
                   -> CmmExpr -> FCode ()
    tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
    tickyAllocPrim CmmExpr
    _hdr CmmExpr
    _goods CmmExpr
    _slop = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      FastString -> FCode ()
    bumpTickyCounter    (String -> FastString
    fsLit String
    "ALLOC_PRIM_ctr")
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_PRIM_adm") CmmExpr
    _hdr
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_PRIM_gds") CmmExpr
    _goods
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_PRIM_slp") CmmExpr
    _slop

    tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
    tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
    tickyAllocThunk CmmExpr
    _goods CmmExpr
    _slop = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
        -- TODO is it ever called with a Single-Entry thunk?
      FastString -> FCode ()
    bumpTickyCounter    (String -> FastString
    fsLit String
    "ALLOC_UP_THK_ctr")
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_THK_gds") CmmExpr
    _goods
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_THK_slp") CmmExpr
    _slop

    tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
    tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
    tickyAllocPAP CmmExpr
    _goods CmmExpr
    _slop = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ do
      FastString -> FCode ()
    bumpTickyCounter    (String -> FastString
    fsLit String
    "ALLOC_PAP_ctr")
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_PAP_gds") CmmExpr
    _goods
      FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE (String -> FastString
    fsLit String
    "ALLOC_PAP_slp") CmmExpr
    _slop

    tickyHeapCheck :: FCode ()
    tickyHeapCheck :: FCode ()
    tickyHeapCheck = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "HEAP_CHK_ctr")

    tickyStackCheck :: FCode ()
    tickyStackCheck :: FCode ()
    tickyStackCheck = FCode () -> FCode ()
    ifTicky forall a b. (a -> b) -> a -> b
    $ FastString -> FCode ()
    bumpTickyCounter (String -> FastString
    fsLit String
    "STK_CHK_ctr")

    -- -----------------------------------------------------------------------------
    -- Ticky utils

    ifTicky :: FCode () -> FCode ()
    ifTicky :: FCode () -> FCode ()
    ifTicky FCode ()
    code =
      forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \DynFlags
    dflags -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Ticky DynFlags
    dflags) FCode ()
    code

    tickyAllocdIsOn :: FCode Bool
    tickyAllocdIsOn :: FCode Bool
    tickyAllocdIsOn = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Ticky_Allocd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags

    tickyLNEIsOn :: FCode Bool
    tickyLNEIsOn :: FCode Bool
    tickyLNEIsOn = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Ticky_LNE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags

    tickyDynThunkIsOn :: FCode Bool
    tickyDynThunkIsOn :: FCode Bool
    tickyDynThunkIsOn = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_Ticky_Dyn_Thunk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags

    ifTickyAllocd :: FCode () -> FCode ()
    ifTickyAllocd :: FCode () -> FCode ()
    ifTickyAllocd FCode ()
    code = FCode Bool
    tickyAllocdIsOn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Bool
    b -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    b FCode ()
    code

    ifTickyLNE :: FCode () -> FCode ()
    ifTickyLNE :: FCode () -> FCode ()
    ifTickyLNE FCode ()
    code = FCode Bool
    tickyLNEIsOn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Bool
    b -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    b FCode ()
    code

    ifTickyDynThunk :: FCode () -> FCode ()
    ifTickyDynThunk :: FCode () -> FCode ()
    ifTickyDynThunk FCode ()
    code = FCode Bool
    tickyDynThunkIsOn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Bool
    b -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    b FCode ()
    code

    bumpTickyCounter :: FastString -> FCode ()
    bumpTickyCounter :: FastString -> FCode ()
    bumpTickyCounter FastString
    lbl = CLabel -> FCode ()
    bumpTickyLbl (FastString -> CLabel
    mkRtsCmmDataLabel FastString
    lbl)

    bumpTickyCounterBy :: FastString -> Int -> FCode ()
    bumpTickyCounterBy :: FastString -> Int -> FCode ()
    bumpTickyCounterBy FastString
    lbl = CLabel -> Int -> FCode ()
    bumpTickyLblBy (FastString -> CLabel
    mkRtsCmmDataLabel FastString
    lbl)

    bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
    bumpTickyCounterByE FastString
    lbl = CLabel -> CmmExpr -> FCode ()
    bumpTickyLblByE (FastString -> CLabel
    mkRtsCmmDataLabel FastString
    lbl)

    bumpTickyEntryCount :: CLabel -> FCode ()
    bumpTickyEntryCount :: CLabel -> FCode ()
    bumpTickyEntryCount CLabel
    lbl = do
      Platform
    platform <- FCode Platform
    getPlatform
      CmmLit -> FCode ()
    bumpTickyLit (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    lbl (PlatformConstants -> Int
    pc_OFFSET_StgEntCounter_entry_count (Platform -> PlatformConstants
    platformConstants Platform
    platform)))

    bumpTickyAllocd :: CLabel -> Int -> FCode ()
    bumpTickyAllocd :: CLabel -> Int -> FCode ()
    bumpTickyAllocd CLabel
    lbl Int
    bytes = do
      Platform
    platform <- FCode Platform
    getPlatform
      CmmLit -> Int -> FCode ()
    bumpTickyLitBy (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    lbl (PlatformConstants -> Int
    pc_OFFSET_StgEntCounter_allocd (Platform -> PlatformConstants
    platformConstants Platform
    platform))) Int
    bytes

    bumpTickyLbl :: CLabel -> FCode ()
    bumpTickyLbl :: CLabel -> FCode ()
    bumpTickyLbl CLabel
    lhs = CmmLit -> Int -> FCode ()
    bumpTickyLitBy (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    lhs Int
    0) Int
    1

    bumpTickyLblBy :: CLabel -> Int -> FCode ()
    bumpTickyLblBy :: CLabel -> Int -> FCode ()
    bumpTickyLblBy CLabel
    lhs = CmmLit -> Int -> FCode ()
    bumpTickyLitBy (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    lhs Int
    0)

    bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
    bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
    bumpTickyLblByE CLabel
    lhs = CmmLit -> CmmExpr -> FCode ()
    bumpTickyLitByE (CLabel -> Int -> CmmLit
    cmmLabelOffB CLabel
    lhs Int
    0)

    bumpTickyLit :: CmmLit -> FCode ()
    bumpTickyLit :: CmmLit -> FCode ()
    bumpTickyLit CmmLit
    lhs = CmmLit -> Int -> FCode ()
    bumpTickyLitBy CmmLit
    lhs Int
    1

    bumpTickyLitBy :: CmmLit -> Int -> FCode ()
    bumpTickyLitBy :: CmmLit -> Int -> FCode ()
    bumpTickyLitBy CmmLit
    lhs Int
    n = do
      Platform
    platform <- FCode Platform
    getPlatform
      CmmAGraph -> FCode ()
    emit (CmmType -> CmmExpr -> Int -> CmmAGraph
    addToMem (Platform -> CmmType
    bWord Platform
    platform) (CmmLit -> CmmExpr
    CmmLit CmmLit
    lhs) Int
    n)

    bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
    bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
    bumpTickyLitByE CmmLit
    lhs CmmExpr
    e = do
      Platform
    platform <- FCode Platform
    getPlatform
      CmmAGraph -> FCode ()
    emit (CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
    addToMemE (Platform -> CmmType
    bWord Platform
    platform) (CmmLit -> CmmExpr
    CmmLit CmmLit
    lhs) CmmExpr
    e)

    bumpHistogram :: FastString -> Int -> FCode ()
    bumpHistogram :: FastString -> Int -> FCode ()
    bumpHistogram FastString
    lbl Int
    n = do
        Platform
    platform <- FCode Platform
    getPlatform
        let offset :: Int
    offset = Int
    n forall a. Ord a => a -> a -> a
    `min` (PlatformConstants -> Int
    pc_TICKY_BIN_COUNT (Platform -> PlatformConstants
    platformConstants Platform
    platform) forall a. Num a => a -> a -> a
    - Int
    1)
        CmmAGraph -> FCode ()
    emit (CmmType -> CmmExpr -> Int -> CmmAGraph
    addToMem (Platform -> CmmType
    bWord Platform
    platform)
               (Platform -> Width -> CmmExpr -> CmmExpr -> CmmExpr
    cmmIndexExpr Platform
    platform
                    (Platform -> Width
    wordWidth Platform
    platform)
                    (CmmLit -> CmmExpr
    CmmLit (CLabel -> CmmLit
    CmmLabel (FastString -> CLabel
    mkRtsCmmDataLabel FastString
    lbl)))
                    (CmmLit -> CmmExpr
    CmmLit (Integer -> Width -> CmmLit
    CmmInt (forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    offset) (Platform -> Width
    wordWidth Platform
    platform))))
               Int
    1)

    ------------------------------------------------------------------
    -- Showing the "type category" for ticky-ticky profiling

    showTypeCategory :: Type -> Char
      {-
            +           dictionary

            >           function

            {C,I,F,D,W} char, int, float, double, word
            {c,i,f,d,w} unboxed ditto

            T           tuple

            P           other primitive type
            p           unboxed ditto

            L           list
            E           enumeration type
            S           other single-constructor type
            M           other multi-constructor data-con type

            .           other type

            -           reserved for others to mark as "uninteresting"

      Accurate as of Mar 2013, but I eliminated the Array category instead
      of updating it, for simplicity. It's in P/p, I think --NSF

        -}
    showTypeCategory :: Type -> Char
    showTypeCategory Type
    ty
      | Type -> Bool
    isDictTy Type
    ty = Char
    '+'
      | Bool
    otherwise = case HasCallStack => Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe Type
    ty of
      Maybe (TyCon, [Type])
    Nothing -> Char
    '.'
      Just (TyCon
    tycon, [Type]
    _) ->
        (if TyCon -> Bool
    isUnliftedTyCon TyCon
    tycon then Char -> Char
    Data.Char.toLower else forall a. a -> a
    id) forall a b. (a -> b) -> a -> b
    $
        let anyOf :: [Unique] -> Bool
    anyOf [Unique]
    us = forall a. Uniquable a => a -> Unique
    getUnique TyCon
    tycon forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Unique]
    us in
        case () of
          ()
    _ | [Unique] -> Bool
    anyOf [Unique
    funTyConKey] -> Char
    '>'
            | [Unique] -> Bool
    anyOf [Unique
    charPrimTyConKey, Unique
    charTyConKey] -> Char
    'C'
            | [Unique] -> Bool
    anyOf [Unique
    doublePrimTyConKey, Unique
    doubleTyConKey] -> Char
    'D'
            | [Unique] -> Bool
    anyOf [Unique
    floatPrimTyConKey, Unique
    floatTyConKey] -> Char
    'F'
            | [Unique] -> Bool
    anyOf [Unique
    intPrimTyConKey, Unique
    int32PrimTyConKey, Unique
    int64PrimTyConKey,
                     Unique
    intTyConKey, Unique
    int8TyConKey, Unique
    int16TyConKey, Unique
    int32TyConKey, Unique
    int64TyConKey
                    ] -> Char
    'I'
            | [Unique] -> Bool
    anyOf [Unique
    wordPrimTyConKey, Unique
    word32PrimTyConKey, Unique
    word64PrimTyConKey, Unique
    wordTyConKey,
                     Unique
    word8TyConKey, Unique
    word16TyConKey, Unique
    word32TyConKey, Unique
    word64TyConKey
                    ] -> Char
    'W'
            | [Unique] -> Bool
    anyOf [Unique
    listTyConKey] -> Char
    'L'
            | TyCon -> Bool
    isTupleTyCon TyCon
    tycon       -> Char
    'T'
            | TyCon -> Bool
    isPrimTyCon TyCon
    tycon        -> Char
    'P'
            | TyCon -> Bool
    isEnumerationTyCon TyCon
    tycon -> Char
    'E'
            | forall a. Maybe a -> Bool
    isJust (TyCon -> Maybe DataCon
    tyConSingleDataCon_maybe TyCon
    tycon) -> Char
    'S'
            | Bool
    otherwise -> Char
    'M' -- oh, well...