{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
--
-- 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 cmm/CLabel.hs to manage labels

  * cmm/CmmParse.y 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,

  tickyUnknownCall, tickyDirectCall,

  tickyPushUpdateFrame,
  tickyUpdateFrameOmitted,

  tickyEnterDynCon,
  tickyEnterStaticCon,
  tickyEnterViaNode,

  tickyEnterFun,
  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
                                              -- thunks only
  tickyEnterLNE,

  tickyUpdateBhCaf,
  tickyBlackHole,
  tickyUnboxedTupleReturn,
  tickyReturnOldCon, tickyReturnNewCon,

  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
  tickySlowCall, tickySlowCallPat,
  ) where

import GhcPrelude

import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad

import StgSyn
import CmmExpr
import MkGraph
import CmmUtils
import CLabel
import SMRep

import Name
import Id
import BasicTypes
import FastString
import Outputable
import Util

import DynFlags

-- Turgid imports for showTypeCategory
import PrelNames
import TcType
import TyCon
import Predicate

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

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

data TickyClosureType
    = TickyFun
        Bool -- True <-> single entry
    | TickyCon
    | 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 :: Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun Bool
single_entry = TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
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 :: 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 TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
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
  Bool -> FCode Bool
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 :: 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 TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
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 :: 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 TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
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
  -> FCode a
  -> FCode a
withNewTickyCounterCon :: Name -> FCode a -> FCode a
withNewTickyCounterCon 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 TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
forall a.
TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounter TickyClosureType
TickyCon Name
name [] FCode a
code

-- args does not include the void arguments
withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounter :: 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
  CLabel -> FCode a -> FCode a
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
    (FCode () -> FCode CLabel -> FCode CLabel
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CLabel -> FCode CLabel
forall (m :: * -> *) a. Monad m => a -> m a
return CLabel
ctr_lbl) (FCode () -> FCode CLabel) -> FCode () -> FCode CLabel
forall a b. (a -> b) -> a -> b
$
    FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
        { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; 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 = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                    ext :: SDoc
ext = case TickyClosureType
cloType of
                              TickyFun Bool
single_entry -> SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                                  [String -> SDoc
text String
"fun"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
text String
"se"|Bool
single_entry]
                              TickyClosureType
TickyCon -> SDoc -> SDoc
parens (String -> SDoc
text String
"con")
                              TickyThunk Bool
upd Bool
std -> SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                                  [String -> SDoc
text String
"thk"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [String -> SDoc
text String
"se"|Bool -> Bool
not Bool
upd] [SDoc] -> [SDoc] -> [SDoc]
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 -> String -> SDoc
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
<+> Unique -> 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 (Module -> SDoc
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 (String -> FCode CmmLit) -> String -> FCode CmmLit
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 (String -> FCode CmmLit) -> String -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ (NonVoid Id -> Char) -> [NonVoid Id] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Char
showTypeCategory (Type -> Char) -> (NonVoid Id -> Type) -> NonVoid Id -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType (Id -> Type) -> (NonVoid Id -> Id) -> NonVoid Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
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.
            [ DynFlags -> Int -> CmmLit
mkIntCLit DynFlags
dflags Int
0,               -- registered?
              DynFlags -> Int -> CmmLit
mkIntCLit DynFlags
dflags ([NonVoid Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NonVoid Id]
args),   -- Arity
              DynFlags -> Int -> CmmLit
mkIntCLit DynFlags
dflags Int
0,               -- Heap allocated for this thing
              CmmLit
fun_descr_lit,
              CmmLit
arg_descr_lit,
              DynFlags -> CmmLit
zeroCLit DynFlags
dflags,          -- Entries into this thing
              DynFlags -> CmmLit
zeroCLit DynFlags
dflags,          -- Heap allocated by this thing
              DynFlags -> CmmLit
zeroCLit DynFlags
dflags                   -- Link to next StgEntCounter
            ]
        }

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

tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
tickyPushUpdateFrame :: FCode ()
tickyPushUpdateFrame    = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted :: FCode ()
tickyUpdateFrameOmitted = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
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, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
tickyEnterDynCon :: FCode ()
tickyEnterDynCon      = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_DYN_CON_ctr")
tickyEnterStaticCon :: FCode ()
tickyEnterStaticCon   = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_STATIC_CON_ctr")
tickyEnterViaNode :: FCode ()
tickyEnterViaNode     = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_VIA_NODE_ctr")

tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk ClosureInfo
cl_info
  = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
    { FastString -> FCode ()
bumpTickyCounter FastString
ctr
    ; Bool
has_ctr <- Bool -> FCode Bool
thunkHasCounter Bool
static
    ; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_ctr (FCode () -> FCode ()) -> FCode () -> FCode ()
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 = ClosureInfo -> Bool
closureSingleEntry 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"

tickyEnterStdThunk :: ClosureInfo -> FCode ()
tickyEnterStdThunk :: ClosureInfo -> FCode ()
tickyEnterStdThunk = ClosureInfo -> FCode ()
tickyEnterThunk

tickyBlackHole :: Bool{-updatable-} -> FCode ()
tickyBlackHole :: Bool -> FCode ()
tickyBlackHole Bool
updatable
  = FCode () -> FCode ()
ifTicky (FastString -> FCode ()
bumpTickyCounter FastString
ctr)
  where
    ctr :: FastString
ctr | Bool
updatable = (String -> FastString
fsLit String
"UPD_BH_SINGLE_ENTRY_ctr")
        | Bool
otherwise = (String -> FastString
fsLit String
"UPD_BH_UPDATABLE_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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
  FastString -> FCode ()
bumpTickyCounter (String -> FastString
fsLit String
"ENT_LNE_ctr")
  FCode () -> FCode ()
ifTickyLNE (FCode () -> FCode ()) -> FCode () -> FCode ()
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
  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
already_registered) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl

registerTickyCtr :: CLabel -> FCode ()
-- Register a ticky counter
--   if ( ! f_ct.registeredp ) {
--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
--          f_ct.registeredp = 1 }
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr CLabel
ctr_lbl = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let
    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
    test :: CmmExpr
test = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Eq (DynFlags -> Width
wordWidth DynFlags
dflags))
              [CmmExpr -> CmmType -> CmmExpr
CmmLoad (CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl
                                (DynFlags -> Int
oFFSET_StgEntCounter_registeredp DynFlags
dflags))) (DynFlags -> CmmType
bWord DynFlags
dflags),
               DynFlags -> CmmExpr
zeroExpr DynFlags
dflags]
    register_stmts :: [CmmAGraph]
register_stmts
      = [ CmmExpr -> CmmExpr -> CmmAGraph
mkStore (CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl (DynFlags -> Int
oFFSET_StgEntCounter_link DynFlags
dflags)))
                   (CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
ticky_entry_ctrs (DynFlags -> CmmType
bWord DynFlags
dflags))
        , CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ticky_entry_ctrs (CLabel -> CmmExpr
mkLblExpr CLabel
ctr_lbl)
        , CmmExpr -> CmmExpr -> CmmAGraph
mkStore (CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ctr_lbl
                                (DynFlags -> Int
oFFSET_StgEntCounter_registeredp DynFlags
dflags)))
                   (DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
dflags Int
1) ]
    ticky_entry_ctrs :: CmmExpr
ticky_entry_ctrs = CLabel -> CmmExpr
mkLblExpr (FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ticky_entry_ctrs"))
  CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
test ([CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph]
register_stmts)

tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
tickyReturnOldCon :: Int -> FCode ()
tickyReturnOldCon Int
arity
  = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 [StgArg] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
arity = FCode ()
tickyKnownCallExact
  | Bool
otherwise = do FCode ()
tickyKnownCallExtraArgs
                   [PrimRep] -> FCode ()
tickySlowCallPat ((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
forall a b. (a -> b) -> [a] -> [b]
map StgArg -> PrimRep
argPrimRep (Int -> [StgArg] -> [StgArg]
forall a. Int -> [a] -> [a]
drop Int
arity [StgArg]
args))

tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs :: FCode ()
tickyKnownCallTooFewArgs = FCode () -> FCode ()
ifTicky (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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
_ [] = () -> FCode ()
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 ((StgArg -> PrimRep) -> [StgArg] -> [PrimRep]
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
  let argReps :: [ArgRep]
argReps = (PrimRep -> ArgRep) -> [PrimRep] -> [ArgRep]
forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> ArgRep
toArgRep [PrimRep]
args
      (FastString
_, Int
n_matched) = [ArgRep] -> (FastString, Int)
slowCallPattern [ArgRep]
argReps
  in if Int
n_matched Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& [PrimRep]
args [PrimRep] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n_matched
     then CLabel -> FCode ()
bumpTickyLbl (CLabel -> FCode ()) -> CLabel -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> CLabel
mkRtsSlowFastTickyCtrLabel (String -> CLabel) -> String -> CLabel
forall a b. (a -> b) -> a -> b
$ (ArgRep -> String) -> [ArgRep] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Data.Char.toLower (String -> String) -> (ArgRep -> String) -> ArgRep -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgRep -> String
argRepString) [ArgRep]
argReps
     else FastString -> FCode ()
bumpTickyCounter (FastString -> FCode ()) -> FastString -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags FCode DynFlags -> (DynFlags -> FCode ()) -> FCode ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DynFlags
dflags ->
  let bytes :: Int
bytes = DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> SMRep -> Int
heapClosureSizeW DynFlags
dflags 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 (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ case Maybe Id
mb_id of
        Maybe Id
Nothing -> () -> FCode ()
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

  in case () of
    ()
_ | SMRep -> Bool
isConRep SMRep
rep   ->
          FCode () -> FCode ()
ifTickyDynThunk FCode ()
countSpecific FCode () -> FCode () -> FCode ()
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 FCode () -> FCode () -> FCode ()
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 FCode () -> FCode () -> FCode ()
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      -> String -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
    do  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        ; CLabel
ticky_ctr <- FCode CLabel
getTickyCtrLabel
        ; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs ([CmmAGraph] -> CmmAGraph) -> [CmmAGraph] -> CmmAGraph
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then []
          else let !bytes :: Int
bytes = DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hp in [
            -- Bump the allocation total in the closure's StgEntCounter
            CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (DynFlags -> CmmType
rEP_StgEntCounter_allocs DynFlags
dflags)
                     (CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
ticky_ctr (DynFlags -> Int
oFFSET_StgEntCounter_allocs DynFlags
dflags)))
                     Int
bytes,
            -- Bump the global allocation total ALLOC_HEAP_tot
            CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl (DynFlags -> CmmType
bWord DynFlags
dflags)
                        (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 (DynFlags -> CmmType
bWord DynFlags
dflags)
                             (FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"ALLOC_HEAP_ctr"))
                             Int
1
            ]}


--------------------------------------------------------------------------------
-- these three are only called from CmmParse.y (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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 (FCode () -> FCode ()) -> FCode () -> FCode ()
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 =
  FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags FCode DynFlags -> (DynFlags -> FCode ()) -> FCode ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \DynFlags
dflags -> Bool -> FCode () -> FCode ()
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 (DynFlags -> Bool) -> FCode DynFlags -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

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

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

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

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

ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk FCode ()
code = FCode Bool
tickyDynThunkIsOn FCode Bool -> (Bool -> FCode ()) -> FCode ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> FCode () -> FCode ()
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
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmLit -> FCode ()
bumpTickyLit (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (DynFlags -> Int
oFFSET_StgEntCounter_entry_count DynFlags
dflags))

bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd CLabel
lbl Int
bytes = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmLit -> Int -> FCode ()
bumpTickyLitBy (CLabel -> Int -> CmmLit
cmmLabelOffB CLabel
lbl (DynFlags -> Int
oFFSET_StgEntCounter_allocd DynFlags
dflags)) 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
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (DynFlags -> CmmType
bWord DynFlags
dflags) (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) Int
n)

bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE CmmLit
lhs CmmExpr
e = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE (DynFlags -> CmmType
bWord DynFlags
dflags) (CmmLit -> CmmExpr
CmmLit CmmLit
lhs) CmmExpr
e)

bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram FastString
lbl Int
n = do
    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let offset :: Int
offset = Int
n Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` (DynFlags -> Int
tICKY_BIN_COUNT DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (DynFlags -> CmmType
bWord DynFlags
dflags)
           (DynFlags -> Width -> CmmExpr -> CmmExpr -> CmmExpr
cmmIndexExpr DynFlags
dflags
                (DynFlags -> Width
wordWidth DynFlags
dflags)
                (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (FastString -> CLabel
mkRtsCmmDataLabel FastString
lbl)))
                (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset) (DynFlags -> Width
wordWidth DynFlags
dflags))))
           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])
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 Char -> Char
forall a. a -> a
id) (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$
    let anyOf :: t Unique -> Bool
anyOf t Unique
us = TyCon -> Unique
forall a. Uniquable a => a -> Unique
getUnique TyCon
tycon Unique -> t Unique -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Unique
us in
    case () of
      ()
_ | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
funTyConKey] -> Char
'>'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
charPrimTyConKey, Unique
charTyConKey] -> Char
'C'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
doublePrimTyConKey, Unique
doubleTyConKey] -> Char
'D'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
floatPrimTyConKey, Unique
floatTyConKey] -> Char
'F'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
intPrimTyConKey, Unique
int32PrimTyConKey, Unique
int64PrimTyConKey,
                 Unique
intTyConKey, Unique
int8TyConKey, Unique
int16TyConKey, Unique
int32TyConKey, Unique
int64TyConKey
                ] -> Char
'I'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t Unique -> Bool
anyOf [Unique
wordPrimTyConKey, Unique
word32PrimTyConKey, Unique
word64PrimTyConKey, Unique
wordTyConKey,
                 Unique
word8TyConKey, Unique
word16TyConKey, Unique
word32TyConKey, Unique
word64TyConKey
                ] -> Char
'W'
        | [Unique] -> Bool
forall (t :: * -> *). Foldable t => t 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'
        | Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isJust (TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tycon) -> Char
'S'
        | Bool
otherwise -> Char
'M' -- oh, well...