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

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

        -- infoTablePRov
        initInfoTableProv, emitInfoTableProv,

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

        saveCurrentCostCentre, restoreCurrentCostCentre,

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

import GHC.Prelude

import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Lit
import GHC.Runtime.Heap.Layout

import GHC.Cmm.Graph
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel

import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.ForeignStubs
import GHC.Data.FastString
import GHC.Unit.Module as Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Driver.CodeOutput ( ipInitCode )

import GHC.Utils.Encoding

import Control.Monad
import Data.Char       (ord)
import Data.Bifunctor  (first)
import GHC.Utils.Monad (whenM)

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

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

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

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

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 :: Platform
               -> CmmExpr        -- A closure pointer
               -> CmmExpr        -- The cost centre from that closure
costCentreFrom :: Platform -> CmmExpr -> CmmExpr
costCentreFrom Platform
platform CmmExpr
cl = CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
cl (PlatformConstants -> Int
pc_OFFSET_StgHeader_ccs (Platform -> PlatformConstants
platformConstants Platform
platform))) (Platform -> CmmType
ccsType Platform
platform) AlignmentSpec
NaturallyAligned

-- | The profiling header words in a static closure
staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]
staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]
staticProfHdr Profile
profile CostCentreStack
ccs
  | Profile -> Bool
profileIsProfiling Profile
profile = [CostCentreStack -> CmmLit
mkCCostCentreStack CostCentreStack
ccs, Platform -> CmmLit
staticLdvInit Platform
platform]
  | Bool
otherwise                  = []
  where platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

-- | Profiling header words in a dynamic closure
dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]
dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]
dynProfHdr Profile
profile CmmExpr
ccs
  | Profile -> Bool
profileIsProfiling Profile
profile = [CmmExpr
ccs, Platform -> CmmExpr
dynLdvInit (Profile -> Platform
profilePlatform Profile
profile)]
  | Bool
otherwise                  = []

-- | 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 Platform
platform <- FCode Platform
getPlatform
       CmmExpr -> CmmExpr -> FCode ()
emitStore (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
frame (PlatformConstants -> Int
pc_OFFSET_StgHeader_ccs (Platform -> PlatformConstants
platformConstants Platform
platform))) 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 Bool
sccProfilingEnabled <- StgToCmmConfig -> Bool
stgToCmmSCCProfiling (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
       Platform
platform            <- FCode Platform
getPlatform
       if Bool -> Bool
not Bool
sccProfilingEnabled
           then Maybe LocalReg -> FCode (Maybe LocalReg)
forall a. a -> FCode a
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 (Platform -> CmmType
ccType Platform
platform)
                   CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
local_cc) CmmExpr
cccsExpr
                   Maybe LocalReg -> FCode (Maybe LocalReg)
forall a. a -> FCode a
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 a. a -> FCode a
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 Profile
profile <- FCode Profile
getProfile
       let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
       CmmExpr -> CmmExpr -> FCode ()
profAlloc (Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Profile -> SMRep -> Int
heapClosureSizeW Profile
profile 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 Profile
profile <- FCode Profile
getProfile
           let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
           let alloc_rep :: CmmType
alloc_rep = Platform -> CmmType
rEP_CostCentreStack_mem_alloc Platform
platform
           CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
alloc_rep
                       (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
ccs (PlatformConstants -> Int
pc_OFFSET_CostCentreStack_mem_alloc (Platform -> PlatformConstants
platformConstants Platform
platform)))
                       (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (Platform -> Width
wordWidth Platform
platform) (CmmType -> Width
typeWidth CmmType
alloc_rep))
                           -- subtract the "profiling overhead", which is the
                           -- profiling header in a closure.
                           [MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordSub Platform
platform) [ CmmExpr
words, Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (Profile -> Int
profHdrSize Profile
profile)]]
                       )

-- -----------------------------------------------------------------------
-- 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
      Platform
platform <- FCode Platform
getPlatform
      CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmAGraph
storeCurCCS (Platform -> CmmExpr -> CmmExpr
costCentreFrom Platform
platform 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
$
    Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
    do Platform
platform <- FCode Platform
getPlatform
       UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall
         UnitId
rtsUnitId
         (String -> FastString
fsLit String
"enterFunCCS")
         [(CmmExpr
baseExpr, ForeignHint
AddrHint), (Platform -> CmmExpr -> CmmExpr
costCentreFrom Platform
platform CmmExpr
closure, ForeignHint
AddrHint)]
         Bool
False
       -- otherwise we have a top-level function, nothing to do

ifProfiling :: FCode () -> FCode ()
ifProfiling :: FCode () -> FCode ()
ifProfiling = FCode Bool -> FCode () -> FCode ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (StgToCmmConfig -> Bool
stgToCmmSCCProfiling (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig)

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

initCostCentres :: CollectedCCs -> FCode ()
-- Emit the declarations
initCostCentres :: CollectedCCs -> FCode ()
initCostCentres ([CostCentre]
local_CCs, [CostCentreStack]
singleton_CCSs)
  = FCode () -> FCode ()
ifProfiling (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
  { SDocContext
ctx      <- StgToCmmConfig -> SDocContext
stgToCmmContext (StgToCmmConfig -> SDocContext)
-> FCode StgToCmmConfig -> FCode SDocContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
  ; Platform
platform <- FCode Platform
getPlatform
  ; let is_caf :: CmmLit
is_caf | CostCentre -> Bool
isCafCC CostCentre
cc = Platform -> Int -> CmmLit
mkIntCLit Platform
platform (Char -> Int
ord Char
'c') -- 'c' == is a CAF
               | Bool
otherwise  = Platform -> CmmLit
zero Platform
platform
                        -- 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
moduleNameFS
                                        (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName
                                        (GenModule Unit -> ModuleName) -> GenModule Unit -> ModuleName
forall a b. (a -> b) -> a -> b
$ CostCentre -> GenModule Unit
cc_mod CostCentre
cc)
  ; CmmLit
loc <- ByteString -> FCode CmmLit
newByteStringCLit (ByteString -> FCode CmmLit) -> ByteString -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ String -> ByteString
utf8EncodeString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
                   SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall a b. (a -> b) -> a -> b
$! CostCentre -> SrcSpan
costCentreSrcSpan CostCentre
cc)
  ; let
     lits :: [CmmLit]
lits = [ Platform -> CmmLit
zero Platform
platform,  -- StgInt ccID,
              CmmLit
label,          -- char *label,
              CmmLit
modl,           -- char *module,
              CmmLit
loc,            -- char *srcloc,
              CmmLit
zero64,         -- StgWord64 mem_alloc
              Platform -> CmmLit
zero Platform
platform,  -- StgWord time_ticks
              CmmLit
is_caf,         -- StgInt is_caf
              Platform -> CmmLit
zero Platform
platform   -- 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 Platform
platform <- FCode Platform
getPlatform
           let mk_lits :: CostCentre -> [CmmLit]
mk_lits CostCentre
cc = Platform -> CmmLit
zero Platform
platform CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
                            CostCentre -> CmmLit
mkCCostCentre CostCentre
cc CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
                            Int -> CmmLit -> [CmmLit]
forall a. Int -> a -> [a]
replicate (Platform -> Int
sizeof_ccs_words Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) (Platform -> CmmLit
zero Platform
platform)
                -- 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 :: Platform -> CmmLit
zero :: Platform -> CmmLit
zero Platform
platform = Platform -> Int -> CmmLit
mkIntCLit Platform
platform Int
0
zero64 :: CmmLit
zero64 :: CmmLit
zero64 = Integer -> Width -> CmmLit
CmmInt Integer
0 Width
W64

sizeof_ccs_words :: Platform -> Int
sizeof_ccs_words :: Platform -> Int
sizeof_ccs_words Platform
platform
    -- round up to the next word.
  | Int
ms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0   = Int
ws
  | Bool
otherwise = Int
ws Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  where
   (Int
ws,Int
ms) = PlatformConstants -> Int
pc_SIZEOF_CostCentreStack (Platform -> PlatformConstants
platformConstants Platform
platform) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Platform -> Int
platformWordSizeInBytes Platform
platform


initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
-- Emit the declarations
initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
initInfoTableProv [CmmInfoTable]
infos InfoTableProvMap
itmap
  = do
       StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
       let ents :: [InfoProvEnt]
ents       = [CmmInfoTable]
-> GenModule Unit -> InfoTableProvMap -> [InfoProvEnt]
convertInfoProvMap [CmmInfoTable]
infos GenModule Unit
this_mod InfoTableProvMap
itmap
           info_table :: Bool
info_table = StgToCmmConfig -> Bool
stgToCmmInfoTableMap StgToCmmConfig
cfg
           platform :: Platform
platform   = StgToCmmConfig -> Platform
stgToCmmPlatform     StgToCmmConfig
cfg
           this_mod :: GenModule Unit
this_mod   = StgToCmmConfig -> GenModule Unit
stgToCmmThisModule   StgToCmmConfig
cfg
       -- Output the actual IPE data
       (InfoProvEnt -> FCode ()) -> [InfoProvEnt] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ InfoProvEnt -> FCode ()
emitInfoTableProv [InfoProvEnt]
ents
       -- Create the C stub which initialises the IPE map
       CStub -> FCode CStub
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Platform -> GenModule Unit -> [InfoProvEnt] -> CStub
ipInitCode Bool
info_table Platform
platform GenModule Unit
this_mod [InfoProvEnt]
ents)

--- Info Table Prov stuff
emitInfoTableProv :: InfoProvEnt  -> FCode ()
emitInfoTableProv :: InfoProvEnt -> FCode ()
emitInfoTableProv InfoProvEnt
ip = do
  { StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
  ; let mod :: GenModule Unit
mod      = InfoProvEnt -> GenModule Unit
infoProvModule InfoProvEnt
ip
        ctx :: SDocContext
ctx      = StgToCmmConfig -> SDocContext
stgToCmmContext  StgToCmmConfig
cfg
        platform :: Platform
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
  ; let (String
src, String
label) = (String, String)
-> ((RealSrcSpan, String) -> (String, String))
-> Maybe (RealSrcSpan, String)
-> (String, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String
"", String
"") ((RealSrcSpan -> String)
-> (RealSrcSpan, String) -> (String, String)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (SDoc -> String) -> (RealSrcSpan -> SDoc) -> RealSrcSpan -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr)) (InfoProvEnt -> Maybe (RealSrcSpan, String)
infoTableProv InfoProvEnt
ip)
        mk_string :: String -> FCode CmmLit
mk_string    = ByteString -> FCode CmmLit
newByteStringCLit (ByteString -> FCode CmmLit)
-> (String -> ByteString) -> String -> FCode CmmLit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
utf8EncodeString
  ; CmmLit
label <- String -> FCode CmmLit
mk_string String
label
  ; CmmLit
modl  <- ByteString -> FCode CmmLit
newByteStringCLit (FastString -> ByteString
bytesFS (FastString -> ByteString) -> FastString -> ByteString
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS
                                        (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
mod)

  ; CmmLit
ty_string  <- String -> FCode CmmLit
mk_string (InfoProvEnt -> String
infoTableType InfoProvEnt
ip)
  ; CmmLit
loc        <- String -> FCode CmmLit
mk_string String
src
  ; CmmLit
table_name <- String -> FCode CmmLit
mk_string (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx
                             (Platform -> LabelStyle -> CLabel -> SDoc
pprCLabel Platform
platform LabelStyle
CStyle (InfoProvEnt -> CLabel
infoTablePtr InfoProvEnt
ip)))
  ; CmmLit
closure_type <- String -> FCode CmmLit
mk_string (SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx
                               (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ InfoProvEnt -> Int
infoProvEntClosureType InfoProvEnt
ip))
  ; let
     lits :: [CmmLit]
lits = [ CLabel -> CmmLit
CmmLabel (InfoProvEnt -> CLabel
infoTablePtr InfoProvEnt
ip), -- Info table pointer
              CmmLit
table_name,     -- char *table_name
              CmmLit
closure_type,   -- char *closure_desc -- Filled in from the InfoTable
              CmmLit
ty_string,      -- char *ty_string
              CmmLit
label,          -- char *label,
              CmmLit
modl,           -- char *module,
              CmmLit
loc,            -- char *srcloc,
              Platform -> CmmLit
zero Platform
platform   -- struct _InfoProvEnt *link
            ]
  ; CLabel -> [CmmLit] -> FCode ()
emitDataLits (InfoProvEnt -> CLabel
mkIPELabel InfoProvEnt
ip) [CmmLit]
lits
  }
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack

emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC CostCentre
cc Bool
tick Bool
push = FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
  do Platform
platform <- FCode Platform
getPlatform
     LocalReg
tmp      <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
ccsType Platform
platform)
     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 (Platform -> CmmExpr -> CmmAGraph
bumpSccCount Platform
platform (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 :: Platform -> CmmExpr -> CmmAGraph
bumpSccCount :: Platform -> CmmExpr -> CmmAGraph
bumpSccCount Platform
platform CmmExpr
ccs
  = CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem (Platform -> CmmType
rEP_CostCentreStack_scc_count Platform
platform)
         (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
ccs (PlatformConstants -> Int
pc_OFFSET_CostCentreStack_scc_count (Platform -> PlatformConstants
platformConstants Platform
platform))) Int
1

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

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

--
-- Initial value of the LDV field in a dynamic closure
--
dynLdvInit :: Platform -> CmmExpr
dynLdvInit :: Platform -> CmmExpr
dynLdvInit Platform
platform =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
  MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordOr Platform
platform) [
      MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordShl Platform
platform) [Platform -> CmmExpr
loadEra Platform
platform, Platform -> Int -> CmmExpr
mkIntExpr Platform
platform (PlatformConstants -> Int
pc_LDV_SHIFT (Platform -> PlatformConstants
platformConstants Platform
platform))],
      CmmLit -> CmmExpr
CmmLit (Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (PlatformConstants -> Integer
pc_ILDV_STATE_CREATE (Platform -> PlatformConstants
platformConstants Platform
platform)))
  ]

--
-- Initialise the LDV word of a new closure
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate CmmExpr
closure = do
  Platform
platform <- FCode Platform
getPlatform
  CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Platform -> CmmExpr -> CmmExpr
ldvWord Platform
platform CmmExpr
closure) (Platform -> CmmExpr
dynLdvInit Platform
platform)

--
-- | 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
    Platform
platform <- FCode Platform
getPlatform
    let tag :: Int
tag = Platform -> ClosureInfo -> Int
funTag Platform
platform ClosureInfo
closure_info
    -- don't forget to subtract node's tag
    CmmExpr -> FCode ()
ldvEnter (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
node_reg) (-Int
tag))

ldvEnter :: CmmExpr -> FCode ()
-- Argument is a closure pointer
ldvEnter :: CmmExpr -> FCode ()
ldvEnter CmmExpr
cl_ptr = do
    Platform
platform <- FCode Platform
getPlatform
    let constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform
        -- don't forget to subtract node's tag
        ldv_wd :: CmmExpr
ldv_wd = Platform -> CmmExpr -> CmmExpr
ldvWord Platform
platform CmmExpr
cl_ptr
        new_ldv_wd :: CmmExpr
new_ldv_wd = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord Platform
platform
                        (Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform (Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform CmmExpr
ldv_wd)
                                             (CmmLit -> CmmExpr
CmmLit (Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (PlatformConstants -> Integer
pc_ILDV_CREATE_MASK PlatformConstants
constants))))
                        (Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord Platform
platform (Platform -> CmmExpr
loadEra Platform
platform) (CmmLit -> CmmExpr
CmmLit (Platform -> Integer -> CmmLit
mkWordCLit Platform
platform (PlatformConstants -> Integer
pc_ILDV_STATE_USE PlatformConstants
constants))))
    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 (Platform -> MachOp
mo_wordUGt Platform
platform) [Platform -> CmmExpr
loadEra Platform
platform, CmmLit -> CmmExpr
CmmLit (Platform -> CmmLit
zeroCLit Platform
platform)])
                     (CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ldv_wd CmmExpr
new_ldv_wd)
                     CmmAGraph
mkNop

loadEra :: Platform -> CmmExpr
loadEra :: Platform -> CmmExpr
loadEra Platform
platform = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (Platform -> Width
cIntWidth Platform
platform) (Platform -> Width
wordWidth Platform
platform))
    [CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (CLabel -> CmmExpr
mkLblExpr (FastString -> CLabel
mkRtsCmmDataLabel (String -> FastString
fsLit String
"era")))
             (Platform -> CmmType
cInt Platform
platform)
             AlignmentSpec
NaturallyAligned]

-- | Takes the address of a closure, and returns
-- the address of the LDV word in the closure
ldvWord :: Platform -> CmmExpr -> CmmExpr
ldvWord :: Platform -> CmmExpr -> CmmExpr
ldvWord Platform
platform CmmExpr
closure_ptr
    = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
closure_ptr (PlatformConstants -> Int
pc_OFFSET_StgHeader_ldvw (Platform -> PlatformConstants
platformConstants Platform
platform))