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

module GHC.StgToCmm.Prof (
        initCostCentres, ccType, ccsType,
        mkCCostCentre, mkCCostCentreStack,

        -- Cost-centre Profiling
        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
        enterCostCentreThunk, enterCostCentreFun,
        costCentreFrom,
        storeCurCCS,
        emitSetCCC,

        saveCurrentCostCentre, restoreCurrentCostCentre,

        -- Lag/drag/void stuff
        ldvEnter, ldvEnterClosure, ldvRecordCreate
  ) where

import GhcPrelude

import GHC.StgToCmm.Closure
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
import SMRep

import MkGraph
import Cmm
import CmmUtils
import CLabel

import CostCentre
import DynFlags
import FastString
import Module
import Outputable

import Control.Monad
import Data.Char (ord)

-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
--
-----------------------------------------------------------------------------

-- Expression representing the current cost centre stack
ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
ccsType :: DynFlags -> CmmType
ccsType = DynFlags -> CmmType
bWord

ccType :: DynFlags -> CmmType -- Type of a cost centre
ccType :: DynFlags -> CmmType
ccType = DynFlags -> CmmType
bWord

storeCurCCS :: CmmExpr -> CmmAGraph
storeCurCCS :: CmmExpr -> CmmAGraph
storeCurCCS CmmExpr
e = CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cccsReg CmmExpr
e

mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre CostCentre
cc = CLabel -> CmmLit
CmmLabel (CostCentre -> CLabel
mkCCLabel CostCentre
cc)

mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack CostCentreStack
ccs = CLabel -> CmmLit
CmmLabel (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs)

costCentreFrom :: DynFlags
               -> CmmExpr         -- A closure pointer
               -> CmmExpr        -- The cost centre from that closure
costCentreFrom :: DynFlags -> CmmExpr -> CmmExpr
costCentreFrom DynFlags
dflags CmmExpr
cl = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
cl (DynFlags -> ByteOff
oFFSET_StgHeader_ccs DynFlags
dflags)) (DynFlags -> CmmType
ccsType DynFlags
dflags)

-- | The profiling header words in a static closure
staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr DynFlags
dflags CostCentreStack
ccs
 = DynFlags -> [CmmLit] -> [CmmLit]
forall a. DynFlags -> [a] -> [a]
ifProfilingL DynFlags
dflags [CostCentreStack -> CmmLit
mkCCostCentreStack CostCentreStack
ccs, DynFlags -> CmmLit
staticLdvInit DynFlags
dflags]

-- | Profiling header words in a dynamic closure
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
dynProfHdr DynFlags
dflags CmmExpr
ccs = DynFlags -> [CmmExpr] -> [CmmExpr]
forall a. DynFlags -> [a] -> [a]
ifProfilingL DynFlags
dflags [CmmExpr
ccs, DynFlags -> CmmExpr
dynLdvInit DynFlags
dflags]

-- | Initialise the profiling field of an update frame
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf CmmExpr
frame
  = FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$        -- frame->header.prof.ccs = CCCS
    do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmExpr -> CmmExpr -> FCode ()
emitStore (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
frame (DynFlags -> ByteOff
oFFSET_StgHeader_ccs DynFlags
dflags)) CmmExpr
cccsExpr
        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
        -- is unnecessary because it is not used anyhow.

---------------------------------------------------------------------------
--         Saving and restoring the current cost centre
---------------------------------------------------------------------------

{-        Note [Saving the current cost centre]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The current cost centre is like a global register.  Like other
global registers, it's a caller-saves one.  But consider
        case (f x) of (p,q) -> rhs
Since 'f' may set the cost centre, we must restore it
before resuming rhs.  So we want code like this:
        local_cc = CCC  -- save
        r = f( x )
        CCC = local_cc  -- restore
That is, we explicitly "save" the current cost centre in
a LocalReg, local_cc; and restore it after the call. The
C-- infrastructure will arrange to save local_cc across the
call.

The same goes for join points;
        let j x = join-stuff
        in blah-blah
We want this kind of code:
        local_cc = CCC  -- save
        blah-blah
     J:
        CCC = local_cc  -- restore
-}

saveCurrentCostCentre :: FCode (Maybe LocalReg)
        -- Returns Nothing if profiling is off
saveCurrentCostCentre :: FCode (Maybe LocalReg)
saveCurrentCostCentre
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
           then Maybe LocalReg -> FCode (Maybe LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocalReg
forall a. Maybe a
Nothing
           else do LocalReg
local_cc <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
ccType DynFlags
dflags)
                   CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
local_cc) CmmExpr
cccsExpr
                   Maybe LocalReg -> FCode (Maybe LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
local_cc)

restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Maybe LocalReg
Nothing
  = () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
restoreCurrentCostCentre (Just LocalReg
local_cc)
  = CmmAGraph -> FCode ()
emit (CmmExpr -> CmmAGraph
storeCurCCS (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
local_cc)))


-------------------------------------------------------------------------------
-- Recording allocation in a cost centre
-------------------------------------------------------------------------------

-- | Record the allocation of a closure.  The CmmExpr is the cost
-- centre stack to which to attribute the allocation.
profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc SMRep
rep CmmExpr
ccs
  = FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
    do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmExpr -> CmmExpr -> FCode ()
profAlloc (DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> SMRep -> ByteOff
heapClosureSizeW DynFlags
dflags SMRep
rep)) CmmExpr
ccs

-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
-- in words.
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc CmmExpr
words CmmExpr
ccs
  = FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
        do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           let alloc_rep :: CmmType
alloc_rep = DynFlags -> CmmType
rEP_CostCentreStack_mem_alloc DynFlags
dflags
           CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
alloc_rep
                       (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
ccs (DynFlags -> ByteOff
oFFSET_CostCentreStack_mem_alloc DynFlags
dflags))
                       (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
wordWidth DynFlags
dflags) (CmmType -> Width
typeWidth CmmType
alloc_rep)) ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> CmmExpr
forall a b. (a -> b) -> a -> b
$
                         [MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
dflags) [CmmExpr
words,
                                                         DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> ByteOff
profHdrSize DynFlags
dflags)]]))
                       -- subtract the "profiling overhead", which is the
                       -- profiling header in a closure.

-- -----------------------------------------------------------------------
-- Setting the current cost centre on entry to a closure

enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk CmmExpr
closure =
  FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
      DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmAGraph
storeCurCCS (DynFlags -> CmmExpr -> CmmExpr
costCentreFrom DynFlags
dflags CmmExpr
closure)

enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun CostCentreStack
ccs CmmExpr
closure =
  FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
    if CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
       then do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
               UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall UnitId
rtsUnitId (String -> FastString
fsLit String
"enterFunCCS")
                   [(CmmExpr
baseExpr, ForeignHint
AddrHint),
                    (DynFlags -> CmmExpr -> CmmExpr
costCentreFrom DynFlags
dflags CmmExpr
closure, ForeignHint
AddrHint)] Bool
False
       else () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- top-level function, nothing to do

ifProfiling :: FCode () -> FCode ()
ifProfiling :: FCode () -> FCode ()
ifProfiling FCode ()
code
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
           then FCode ()
code
           else () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

ifProfilingL :: DynFlags -> [a] -> [a]
ifProfilingL :: DynFlags -> [a] -> [a]
ifProfilingL DynFlags
dflags [a]
xs
  | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags = [a]
xs
  | Bool
otherwise                      = []


---------------------------------------------------------------
--        Initialising Cost Centres & CCSs
---------------------------------------------------------------

initCostCentres :: CollectedCCs -> FCode ()
-- Emit the declarations
initCostCentres :: CollectedCCs -> FCode ()
initCostCentres ([CostCentre]
local_CCs, [CostCentreStack]
singleton_CCSs)
  = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
           do (CostCentre -> FCode ()) -> [CostCentre] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentre -> FCode ()
emitCostCentreDecl [CostCentre]
local_CCs
              (CostCentreStack -> FCode ()) -> [CostCentreStack] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentreStack -> FCode ()
emitCostCentreStackDecl [CostCentreStack]
singleton_CCSs


emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl CostCentre
cc = do
  { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  ; let is_caf :: CmmLit
is_caf | CostCentre -> Bool
isCafCC CostCentre
cc = DynFlags -> ByteOff -> CmmLit
mkIntCLit DynFlags
dflags (Char -> ByteOff
ord Char
'c') -- 'c' == is a CAF
               | Bool
otherwise  = DynFlags -> CmmLit
zero DynFlags
dflags
                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
  ; CmmLit
label <- ByteString -> FCode CmmLit
newByteStringCLit (FastString -> ByteString
bytesFS (FastString -> ByteString) -> FastString -> ByteString
forall a b. (a -> b) -> a -> b
$ CostCentre -> FastString
costCentreUserNameFS CostCentre
cc)
  ; CmmLit
modl  <- ByteString -> FCode CmmLit
newByteStringCLit (FastString -> ByteString
bytesFS (FastString -> ByteString) -> FastString -> ByteString
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
Module.moduleNameFS
                                        (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
Module.moduleName
                                        (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ CostCentre -> Module
cc_mod CostCentre
cc)
  ; CmmLit
loc <- ByteString -> FCode CmmLit
newByteStringCLit (ByteString -> FCode CmmLit) -> ByteString -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ FastString -> ByteString
bytesFS (FastString -> ByteString) -> FastString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$
                   DynFlags -> SrcSpan -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (CostCentre -> SrcSpan
costCentreSrcSpan CostCentre
cc)
           -- XXX going via FastString to get UTF-8 encoding is silly
  ; let
     lits :: [CmmLit]
lits = [ DynFlags -> CmmLit
zero DynFlags
dflags,           -- StgInt ccID,
              CmmLit
label,        -- char *label,
              CmmLit
modl,        -- char *module,
              CmmLit
loc,      -- char *srcloc,
              CmmLit
zero64,   -- StgWord64 mem_alloc
              DynFlags -> CmmLit
zero DynFlags
dflags,     -- StgWord time_ticks
              CmmLit
is_caf,   -- StgInt is_caf
              DynFlags -> CmmLit
zero DynFlags
dflags      -- struct _CostCentre *link
            ]
  ; CLabel -> [CmmLit] -> FCode ()
emitDataLits (CostCentre -> CLabel
mkCCLabel CostCentre
cc) [CmmLit]
lits
  }

emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl CostCentreStack
ccs
  = case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
    Just CostCentre
cc ->
        do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
           let mk_lits :: CostCentre -> [CmmLit]
mk_lits CostCentre
cc = DynFlags -> CmmLit
zero DynFlags
dflags CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
                            CostCentre -> CmmLit
mkCCostCentre CostCentre
cc CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
                            ByteOff -> CmmLit -> [CmmLit]
forall a. ByteOff -> a -> [a]
replicate (DynFlags -> ByteOff
sizeof_ccs_words DynFlags
dflags ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- ByteOff
2) (DynFlags -> CmmLit
zero DynFlags
dflags)
                -- Note: to avoid making any assumptions about how the
                -- C compiler (that compiles the RTS, in particular) does
                -- layouts of structs containing long-longs, simply
                -- pad out the struct with zero words until we hit the
                -- size of the overall struct (which we get via DerivedConstants.h)
           CLabel -> [CmmLit] -> FCode ()
emitDataLits (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs) (CostCentre -> [CmmLit]
mk_lits CostCentre
cc)
    Maybe CostCentre
Nothing -> String -> SDoc -> FCode ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"emitCostCentreStackDecl" (CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
ccs)

zero :: DynFlags -> CmmLit
zero :: DynFlags -> CmmLit
zero DynFlags
dflags = DynFlags -> ByteOff -> CmmLit
mkIntCLit DynFlags
dflags ByteOff
0
zero64 :: CmmLit
zero64 :: CmmLit
zero64 = Integer -> Width -> CmmLit
CmmInt Integer
0 Width
W64

sizeof_ccs_words :: DynFlags -> Int
sizeof_ccs_words :: DynFlags -> ByteOff
sizeof_ccs_words DynFlags
dflags
    -- round up to the next word.
  | ByteOff
ms ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOff
0   = ByteOff
ws
  | Bool
otherwise = ByteOff
ws ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
1
  where
   (ByteOff
ws,ByteOff
ms) = DynFlags -> ByteOff
sIZEOF_CostCentreStack DynFlags
dflags ByteOff -> ByteOff -> (ByteOff, ByteOff)
forall a. Integral a => a -> a -> (a, a)
`divMod` DynFlags -> ByteOff
wORD_SIZE DynFlags
dflags

-- ---------------------------------------------------------------------------
-- Set the current cost centre stack

emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC CostCentre
cc Bool
tick Bool
push
 = do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
          then () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else do LocalReg
tmp <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
ccsType DynFlags
dflags)
                  LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre LocalReg
tmp CmmExpr
cccsExpr CostCentre
cc
                  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tick (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraph -> FCode ()
emit (DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
                  Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
push (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraph -> FCode ()
emit (CmmExpr -> CmmAGraph
storeCurCCS (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))

pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre LocalReg
result CmmExpr
ccs CostCentre
cc
  = LocalReg
-> ForeignHint
-> UnitId
-> FastString
-> [(CmmExpr, ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallWithResult LocalReg
result ForeignHint
AddrHint
        UnitId
rtsUnitId
        (String -> FastString
fsLit String
"pushCostCentre") [(CmmExpr
ccs,ForeignHint
AddrHint),
                                (CmmLit -> CmmExpr
CmmLit (CostCentre -> CmmLit
mkCCostCentre CostCentre
cc), ForeignHint
AddrHint)]
        Bool
False

bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount DynFlags
dflags CmmExpr
ccs
  = CmmType -> CmmExpr -> ByteOff -> CmmAGraph
addToMem (DynFlags -> CmmType
rEP_CostCentreStack_scc_count DynFlags
dflags)
         (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
ccs (DynFlags -> ByteOff
oFFSET_CostCentreStack_scc_count DynFlags
dflags)) ByteOff
1

-----------------------------------------------------------------------------
--
--                Lag/drag/void stuff
--
-----------------------------------------------------------------------------

--
-- Initial value for the LDV field in a static closure
--
staticLdvInit :: DynFlags -> CmmLit
staticLdvInit :: DynFlags -> CmmLit
staticLdvInit = DynFlags -> CmmLit
zeroCLit

--
-- Initial value of the LDV field in a dynamic closure
--
dynLdvInit :: DynFlags -> CmmExpr
dynLdvInit :: DynFlags -> CmmExpr
dynLdvInit DynFlags
dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
  MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordOr DynFlags
dflags) [
      MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordShl DynFlags
dflags) [DynFlags -> CmmExpr
loadEra DynFlags
dflags, DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> ByteOff
lDV_SHIFT DynFlags
dflags)],
      CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_STATE_CREATE DynFlags
dflags))
  ]

--
-- Initialise the LDV word of a new closure
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate CmmExpr
closure = do
  DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> CmmExpr
ldvWord DynFlags
dflags CmmExpr
closure) (DynFlags -> CmmExpr
dynLdvInit DynFlags
dflags)

--
-- | Called when a closure is entered, marks the closure as having
-- been "used".  The closure is not an "inherently used" one.  The
-- closure is not @IND@ because that is not considered for LDV profiling.
--
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure ClosureInfo
closure_info CmmReg
node_reg = do
    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let tag :: ByteOff
tag = DynFlags -> ClosureInfo -> ByteOff
funTag DynFlags
dflags ClosureInfo
closure_info
    -- don't forget to substract node's tag
    CmmExpr -> FCode ()
ldvEnter (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
node_reg) (-ByteOff
tag))

ldvEnter :: CmmExpr -> FCode ()
-- Argument is a closure pointer
ldvEnter :: CmmExpr -> FCode ()
ldvEnter CmmExpr
cl_ptr = do
    DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let -- don't forget to substract node's tag
        ldv_wd :: CmmExpr
ldv_wd = DynFlags -> CmmExpr -> CmmExpr
ldvWord DynFlags
dflags CmmExpr
cl_ptr
        new_ldv_wd :: CmmExpr
new_ldv_wd = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord DynFlags
dflags (CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
ldv_wd (DynFlags -> CmmType
bWord DynFlags
dflags))
                                                         (CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_CREATE_MASK DynFlags
dflags))))
                                      (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord DynFlags
dflags (DynFlags -> CmmExpr
loadEra DynFlags
dflags) (CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_STATE_USE DynFlags
dflags))))
    FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
         -- if (era > 0) {
         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
         --                era | LDV_STATE_USE }
        CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUGt DynFlags
dflags) [DynFlags -> CmmExpr
loadEra DynFlags
dflags, CmmLit -> CmmExpr
CmmLit (DynFlags -> CmmLit
zeroCLit DynFlags
dflags)])
                     (CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ldv_wd CmmExpr
new_ldv_wd)
                     CmmAGraph
mkNop

loadEra :: DynFlags -> CmmExpr
loadEra :: DynFlags -> CmmExpr
loadEra DynFlags
dflags = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
cIntWidth DynFlags
dflags) (DynFlags -> Width
wordWidth DynFlags
dflags))
    [CmmExpr -> CmmType -> CmmExpr
CmmLoad (CLabel -> CmmExpr
mkLblExpr (UnitId -> FastString -> CLabel
mkCmmDataLabel UnitId
rtsUnitId (String -> FastString
fsLit String
"era")))
             (DynFlags -> CmmType
cInt DynFlags
dflags)]

ldvWord :: DynFlags -> CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns
-- the address of the LDV word in the closure
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
ldvWord DynFlags
dflags CmmExpr
closure_ptr
    = DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
closure_ptr (DynFlags -> ByteOff
oFFSET_StgHeader_ldvw DynFlags
dflags)