{-# LANGUAGE DeriveDataTypeable #-}
module GHC.Types.CostCentre (
        CostCentre(..), CcName, CCFlavour(..),
                -- All abstract except to friend: ParseIface.y

        CostCentreStack,
        CollectedCCs, emptyCollectedCCs, collectCC,
        currentCCS, dontCareCCS,
        isCurrentCCS,
        maybeSingletonCCS,

        mkUserCC, mkAutoCC, mkAllCafsCC,
        mkSingletonCCS,
        isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,

        pprCostCentreCore,
        costCentreUserName, costCentreUserNameFS,
        costCentreSrcSpan,

        cmpCostCentre   -- used for removing dups in a list
    ) where

import GHC.Prelude

import GHC.Utils.Binary
import GHC.Types.Var
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Data.FastString
import GHC.Types.CostCentre.State

import Data.Data

-----------------------------------------------------------------------------
-- Cost Centres

-- | A Cost Centre is a single @{-# SCC #-}@ annotation.

data CostCentre
  = NormalCC {
                CostCentre -> CCFlavour
cc_flavour  :: CCFlavour,
                 -- ^ Two cost centres may have the same name and
                 -- module but different SrcSpans, so we need a way to
                 -- distinguish them easily and give them different
                 -- object-code labels.  So every CostCentre has an
                 -- associated flavour that indicates how it was
                 -- generated, and flavours that allow multiple instances
                 -- of the same name and module have a deterministic 0-based
                 -- index.
                CostCentre -> CcName
cc_name :: CcName,      -- ^ Name of the cost centre itself
                CostCentre -> Module
cc_mod  :: Module,      -- ^ Name of module defining this CC.
                CostCentre -> SrcSpan
cc_loc  :: SrcSpan
    }

  | AllCafsCC {
                cc_mod  :: Module,      -- Name of module defining this CC.
                cc_loc  :: SrcSpan
    }
  deriving Typeable CostCentre
CostCentre -> DataType
CostCentre -> Constr
(forall b. Data b => b -> b) -> CostCentre -> CostCentre
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CostCentre -> u
forall u. (forall d. Data d => d -> u) -> CostCentre -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostCentre
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CostCentre -> c CostCentre
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostCentre)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CostCentre)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CostCentre -> m CostCentre
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CostCentre -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CostCentre -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> CostCentre -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CostCentre -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostCentre -> r
gmapT :: (forall b. Data b => b -> b) -> CostCentre -> CostCentre
$cgmapT :: (forall b. Data b => b -> b) -> CostCentre -> CostCentre
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CostCentre)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CostCentre)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostCentre)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostCentre)
dataTypeOf :: CostCentre -> DataType
$cdataTypeOf :: CostCentre -> DataType
toConstr :: CostCentre -> Constr
$ctoConstr :: CostCentre -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostCentre
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostCentre
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CostCentre -> c CostCentre
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CostCentre -> c CostCentre
Data

type CcName = FastString

-- | The flavour of a cost centre.
--
-- Index fields represent 0-based indices giving source-code ordering of
-- centres with the same module, name, and flavour.
data CCFlavour = CafCC -- ^ Auto-generated top-level thunk
               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression
               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration
               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage
               deriving (CCFlavour -> CCFlavour -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CCFlavour -> CCFlavour -> Bool
$c/= :: CCFlavour -> CCFlavour -> Bool
== :: CCFlavour -> CCFlavour -> Bool
$c== :: CCFlavour -> CCFlavour -> Bool
Eq, Eq CCFlavour
CCFlavour -> CCFlavour -> Bool
CCFlavour -> CCFlavour -> Ordering
CCFlavour -> CCFlavour -> CCFlavour
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CCFlavour -> CCFlavour -> CCFlavour
$cmin :: CCFlavour -> CCFlavour -> CCFlavour
max :: CCFlavour -> CCFlavour -> CCFlavour
$cmax :: CCFlavour -> CCFlavour -> CCFlavour
>= :: CCFlavour -> CCFlavour -> Bool
$c>= :: CCFlavour -> CCFlavour -> Bool
> :: CCFlavour -> CCFlavour -> Bool
$c> :: CCFlavour -> CCFlavour -> Bool
<= :: CCFlavour -> CCFlavour -> Bool
$c<= :: CCFlavour -> CCFlavour -> Bool
< :: CCFlavour -> CCFlavour -> Bool
$c< :: CCFlavour -> CCFlavour -> Bool
compare :: CCFlavour -> CCFlavour -> Ordering
$ccompare :: CCFlavour -> CCFlavour -> Ordering
Ord, Typeable CCFlavour
CCFlavour -> DataType
CCFlavour -> Constr
(forall b. Data b => b -> b) -> CCFlavour -> CCFlavour
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CCFlavour -> u
forall u. (forall d. Data d => d -> u) -> CCFlavour -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CCFlavour
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CCFlavour -> c CCFlavour
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CCFlavour)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CCFlavour)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CCFlavour -> m CCFlavour
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CCFlavour -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CCFlavour -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> CCFlavour -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CCFlavour -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CCFlavour -> r
gmapT :: (forall b. Data b => b -> b) -> CCFlavour -> CCFlavour
$cgmapT :: (forall b. Data b => b -> b) -> CCFlavour -> CCFlavour
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CCFlavour)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c CCFlavour)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CCFlavour)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CCFlavour)
dataTypeOf :: CCFlavour -> DataType
$cdataTypeOf :: CCFlavour -> DataType
toConstr :: CCFlavour -> Constr
$ctoConstr :: CCFlavour -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CCFlavour
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CCFlavour
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CCFlavour -> c CCFlavour
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CCFlavour -> c CCFlavour
Data)

-- | Extract the index from a flavour
flavourIndex :: CCFlavour -> Int
flavourIndex :: CCFlavour -> Int
flavourIndex CCFlavour
CafCC = Int
0
flavourIndex (ExprCC CostCentreIndex
x) = CostCentreIndex -> Int
unCostCentreIndex CostCentreIndex
x
flavourIndex (DeclCC CostCentreIndex
x) = CostCentreIndex -> Int
unCostCentreIndex CostCentreIndex
x
flavourIndex (HpcCC CostCentreIndex
x) = CostCentreIndex -> Int
unCostCentreIndex CostCentreIndex
x

instance Eq CostCentre where
        CostCentre
c1 == :: CostCentre -> CostCentre -> Bool
== CostCentre
c2 = case CostCentre
c1 CostCentre -> CostCentre -> Ordering
`cmpCostCentre` CostCentre
c2 of { Ordering
EQ -> Bool
True; Ordering
_ -> Bool
False }

instance Ord CostCentre where
        compare :: CostCentre -> CostCentre -> Ordering
compare = CostCentre -> CostCentre -> Ordering
cmpCostCentre

cmpCostCentre :: CostCentre -> CostCentre -> Ordering

cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC  {cc_mod :: CostCentre -> Module
cc_mod = Module
m1}) (AllCafsCC  {cc_mod :: CostCentre -> Module
cc_mod = Module
m2})
  = Module
m1 forall a. Ord a => a -> a -> Ordering
`compare` Module
m2

cmpCostCentre NormalCC {cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
f1, cc_mod :: CostCentre -> Module
cc_mod =  Module
m1, cc_name :: CostCentre -> CcName
cc_name = CcName
n1}
              NormalCC {cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
f2, cc_mod :: CostCentre -> Module
cc_mod =  Module
m2, cc_name :: CostCentre -> CcName
cc_name = CcName
n2}
    -- first key is module name, then centre name, then flavour
  = forall a. Monoid a => [a] -> a
mconcat
      [ Module
m1 forall a. Ord a => a -> a -> Ordering
`compare` Module
m2
      , CcName
n1 CcName -> CcName -> Ordering
`lexicalCompareFS` CcName
n2 -- compare lexically to avoid non-determinism
      , CCFlavour
f1 forall a. Ord a => a -> a -> Ordering
`compare` CCFlavour
f2
      ]

cmpCostCentre CostCentre
other_1 CostCentre
other_2
  = let
        tag1 :: Int
tag1 = CostCentre -> Int
tag_CC CostCentre
other_1
        tag2 :: Int
tag2 = CostCentre -> Int
tag_CC CostCentre
other_2
    in
    if Int
tag1 forall a. Ord a => a -> a -> Bool
< Int
tag2 then Ordering
LT else Ordering
GT
  where
    tag_CC :: CostCentre -> Int
    tag_CC :: CostCentre -> Int
tag_CC (NormalCC   {}) = Int
0
    tag_CC (AllCafsCC  {}) = Int
1


-----------------------------------------------------------------------------
-- Predicates on CostCentre

isCafCC :: CostCentre -> Bool
isCafCC :: CostCentre -> Bool
isCafCC (AllCafsCC {})                  = Bool
True
isCafCC (NormalCC {cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
CafCC}) = Bool
True
isCafCC CostCentre
_                               = Bool
False

-- | Is this a cost-centre which records scc counts
isSccCountCC :: CostCentre -> Bool
isSccCountCC :: CostCentre -> Bool
isSccCountCC CostCentre
cc | CostCentre -> Bool
isCafCC CostCentre
cc  = Bool
False
                | Bool
otherwise   = Bool
True

-- | Is this a cost-centre which can be sccd ?
sccAbleCC :: CostCentre -> Bool
sccAbleCC :: CostCentre -> Bool
sccAbleCC CostCentre
cc | CostCentre -> Bool
isCafCC CostCentre
cc = Bool
False
             | Bool
otherwise  = Bool
True

ccFromThisModule :: CostCentre -> Module -> Bool
ccFromThisModule :: CostCentre -> Module -> Bool
ccFromThisModule CostCentre
cc Module
m = CostCentre -> Module
cc_mod CostCentre
cc forall a. Eq a => a -> a -> Bool
== Module
m


-----------------------------------------------------------------------------
-- Building cost centres

mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC :: CcName -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC CcName
cc_name Module
mod SrcSpan
loc CCFlavour
flavour
  = NormalCC { cc_name :: CcName
cc_name = CcName
cc_name, cc_mod :: Module
cc_mod =  Module
mod, cc_loc :: SrcSpan
cc_loc = SrcSpan
loc,
               cc_flavour :: CCFlavour
cc_flavour = CCFlavour
flavour
    }

mkAutoCC :: Id -> Module -> CostCentre
mkAutoCC :: Id -> Module -> CostCentre
mkAutoCC Id
id Module
mod
  = NormalCC { cc_name :: CcName
cc_name = CcName
str, cc_mod :: Module
cc_mod =  Module
mod,
               cc_loc :: SrcSpan
cc_loc = Name -> SrcSpan
nameSrcSpan (forall a. NamedThing a => a -> Name
getName Id
id),
               cc_flavour :: CCFlavour
cc_flavour = CCFlavour
CafCC
    }
  where
        name :: Name
name = forall a. NamedThing a => a -> Name
getName Id
id
        -- beware: only external names are guaranteed to have unique
        -- Occnames.  If the name is not external, we must append its
        -- Unique.
        -- See bug #249, tests prof001, prof002,  also #2411
        str :: CcName
str | Name -> Bool
isExternalName Name
name = OccName -> CcName
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
id)
            | Bool
otherwise           = OccName -> CcName
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
id)
                                    CcName -> CcName -> CcName
`appendFS`
                                    String -> CcName
mkFastString (Char
'_' forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show (forall a. Uniquable a => a -> Unique
getUnique Name
name))
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC Module
m SrcSpan
loc = AllCafsCC { cc_mod :: Module
cc_mod = Module
m, cc_loc :: SrcSpan
cc_loc = SrcSpan
loc }

-----------------------------------------------------------------------------
-- Cost Centre Stacks

-- | A Cost Centre Stack is something that can be attached to a closure.
-- This is either:
--
--      * the current cost centre stack (CCCS)
--      * a pre-defined cost centre stack (there are several
--        pre-defined CCSs, see below).

data CostCentreStack
  = CurrentCCS          -- Pinned on a let(rec)-bound
                        -- thunk/function/constructor, this says that the
                        -- cost centre to be attached to the object, when it
                        -- is allocated, is whatever is in the
                        -- current-cost-centre-stack register.

  | DontCareCCS         -- We need a CCS to stick in static closures
                        -- (for data), but we *don't* expect them to
                        -- accumulate any costs.  But we still need
                        -- the placeholder.  This CCS is it.

  | SingletonCCS CostCentre

  deriving (CostCentreStack -> CostCentreStack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CostCentreStack -> CostCentreStack -> Bool
$c/= :: CostCentreStack -> CostCentreStack -> Bool
== :: CostCentreStack -> CostCentreStack -> Bool
$c== :: CostCentreStack -> CostCentreStack -> Bool
Eq, Eq CostCentreStack
CostCentreStack -> CostCentreStack -> Bool
CostCentreStack -> CostCentreStack -> Ordering
CostCentreStack -> CostCentreStack -> CostCentreStack
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CostCentreStack -> CostCentreStack -> CostCentreStack
$cmin :: CostCentreStack -> CostCentreStack -> CostCentreStack
max :: CostCentreStack -> CostCentreStack -> CostCentreStack
$cmax :: CostCentreStack -> CostCentreStack -> CostCentreStack
>= :: CostCentreStack -> CostCentreStack -> Bool
$c>= :: CostCentreStack -> CostCentreStack -> Bool
> :: CostCentreStack -> CostCentreStack -> Bool
$c> :: CostCentreStack -> CostCentreStack -> Bool
<= :: CostCentreStack -> CostCentreStack -> Bool
$c<= :: CostCentreStack -> CostCentreStack -> Bool
< :: CostCentreStack -> CostCentreStack -> Bool
$c< :: CostCentreStack -> CostCentreStack -> Bool
compare :: CostCentreStack -> CostCentreStack -> Ordering
$ccompare :: CostCentreStack -> CostCentreStack -> Ordering
Ord)    -- needed for Ord on CLabel


-- synonym for triple which describes the cost centre info in the generated
-- code for a module.
type CollectedCCs
  = ( [CostCentre]       -- local cost-centres that need to be decl'd
    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
    )

emptyCollectedCCs :: CollectedCCs
emptyCollectedCCs :: CollectedCCs
emptyCollectedCCs = ([], [])

collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC CostCentre
cc CostCentreStack
ccs ([CostCentre]
c, [CostCentreStack]
cs) = (CostCentre
cc forall a. a -> [a] -> [a]
: [CostCentre]
c, CostCentreStack
ccs forall a. a -> [a] -> [a]
: [CostCentreStack]
cs)

currentCCS, dontCareCCS :: CostCentreStack

currentCCS :: CostCentreStack
currentCCS              = CostCentreStack
CurrentCCS
dontCareCCS :: CostCentreStack
dontCareCCS             = CostCentreStack
DontCareCCS

-----------------------------------------------------------------------------
-- Predicates on Cost-Centre Stacks

isCurrentCCS :: CostCentreStack -> Bool
isCurrentCCS :: CostCentreStack -> Bool
isCurrentCCS CostCentreStack
CurrentCCS                 = Bool
True
isCurrentCCS CostCentreStack
_                          = Bool
False

isCafCCS :: CostCentreStack -> Bool
isCafCCS :: CostCentreStack -> Bool
isCafCCS (SingletonCCS CostCentre
cc)              = CostCentre -> Bool
isCafCC CostCentre
cc
isCafCCS CostCentreStack
_                              = Bool
False

maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
maybeSingletonCCS (SingletonCCS CostCentre
cc)     = forall a. a -> Maybe a
Just CostCentre
cc
maybeSingletonCCS CostCentreStack
_                     = forall a. Maybe a
Nothing

mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS CostCentre
cc = CostCentre -> CostCentreStack
SingletonCCS CostCentre
cc


-----------------------------------------------------------------------------
-- Printing Cost Centre Stacks.

-- The outputable instance for CostCentreStack prints the CCS as a C
-- expression.

instance Outputable CostCentreStack where
  ppr :: CostCentreStack -> SDoc
ppr CostCentreStack
CurrentCCS        = String -> SDoc
text String
"CCCS"
  ppr CostCentreStack
DontCareCCS       = String -> SDoc
text String
"CCS_DONT_CARE"
  ppr (SingletonCCS CostCentre
cc) = forall a. Outputable a => a -> SDoc
ppr CostCentre
cc SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_ccs"


-----------------------------------------------------------------------------
-- Printing Cost Centres
--
-- There are several different ways in which we might want to print a
-- cost centre:
--
--      - the name of the cost centre, for profiling output (a C string)
--      - the label, i.e. C label for cost centre in .hc file.
--      - the debugging name, for output in -ddump things
--      - the interface name, for printing in _scc_ exprs in iface files.
--
-- The last 3 are derived from costCentreStr below.  The first is given
-- by costCentreName.

instance Outputable CostCentre where
  ppr :: CostCentre -> SDoc
ppr CostCentre
cc = (PprStyle -> SDoc) -> SDoc
getPprStyle forall a b. (a -> b) -> a -> b
$ \ PprStyle
sty ->
           if PprStyle -> Bool
codeStyle PprStyle
sty
           then CostCentre -> SDoc
ppCostCentreLbl CostCentre
cc
           else String -> SDoc
text (CostCentre -> String
costCentreUserName CostCentre
cc)

-- Printing in Core
pprCostCentreCore :: CostCentre -> SDoc
pprCostCentreCore :: CostCentre -> SDoc
pprCostCentreCore (AllCafsCC {cc_mod :: CostCentre -> Module
cc_mod = Module
m})
  = String -> SDoc
text String
"__sccC" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (forall a. Outputable a => a -> SDoc
ppr Module
m)
pprCostCentreCore (NormalCC {cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
flavour, cc_name :: CostCentre -> CcName
cc_name = CcName
n,
                             cc_mod :: CostCentre -> Module
cc_mod = Module
m, cc_loc :: CostCentre -> SrcSpan
cc_loc = SrcSpan
loc})
  = String -> SDoc
text String
"__scc" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
hsep [
        forall a. Outputable a => a -> SDoc
ppr Module
m SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.' SDoc -> SDoc -> SDoc
<> CcName -> SDoc
ftext CcName
n,
        CCFlavour -> SDoc
pprFlavourCore CCFlavour
flavour,
        SDoc -> SDoc
whenPprDebug (forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)
    ])

-- ^ Print a flavour in Core
pprFlavourCore :: CCFlavour -> SDoc
pprFlavourCore :: CCFlavour -> SDoc
pprFlavourCore CCFlavour
CafCC = String -> SDoc
text String
"__C"
pprFlavourCore CCFlavour
f     = Int -> SDoc
pprIdxCore forall a b. (a -> b) -> a -> b
$ CCFlavour -> Int
flavourIndex CCFlavour
f

-- ^ Print a flavour's index in Core
pprIdxCore :: Int -> SDoc
pprIdxCore :: Int -> SDoc
pprIdxCore Int
0 = SDoc
empty
pprIdxCore Int
idx = SDoc -> SDoc
whenPprDebug forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Int
idx

-- Printing as a C label
ppCostCentreLbl :: CostCentre -> SDoc
ppCostCentreLbl :: CostCentre -> SDoc
ppCostCentreLbl (AllCafsCC  {cc_mod :: CostCentre -> Module
cc_mod = Module
m}) = forall a. Outputable a => a -> SDoc
ppr Module
m SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_CAFs_cc"
ppCostCentreLbl (NormalCC {cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
f, cc_name :: CostCentre -> CcName
cc_name = CcName
n, cc_mod :: CostCentre -> Module
cc_mod = Module
m})
  = forall a. Outputable a => a -> SDoc
ppr Module
m SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<> FastZString -> SDoc
ztext (CcName -> FastZString
zEncodeFS CcName
n) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<>
        CCFlavour -> SDoc
ppFlavourLblComponent CCFlavour
f SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_cc"

-- ^ Print the flavour component of a C label
ppFlavourLblComponent :: CCFlavour -> SDoc
ppFlavourLblComponent :: CCFlavour -> SDoc
ppFlavourLblComponent CCFlavour
CafCC = String -> SDoc
text String
"CAF"
ppFlavourLblComponent (ExprCC CostCentreIndex
i) = String -> SDoc
text String
"EXPR" SDoc -> SDoc -> SDoc
<> CostCentreIndex -> SDoc
ppIdxLblComponent CostCentreIndex
i
ppFlavourLblComponent (DeclCC CostCentreIndex
i) = String -> SDoc
text String
"DECL" SDoc -> SDoc -> SDoc
<> CostCentreIndex -> SDoc
ppIdxLblComponent CostCentreIndex
i
ppFlavourLblComponent (HpcCC CostCentreIndex
i) = String -> SDoc
text String
"HPC" SDoc -> SDoc -> SDoc
<> CostCentreIndex -> SDoc
ppIdxLblComponent CostCentreIndex
i

-- ^ Print the flavour index component of a C label
ppIdxLblComponent :: CostCentreIndex -> SDoc
ppIdxLblComponent :: CostCentreIndex -> SDoc
ppIdxLblComponent CostCentreIndex
n =
  case CostCentreIndex -> Int
unCostCentreIndex CostCentreIndex
n of
    Int
0 -> SDoc
empty
    Int
n -> forall a. Outputable a => a -> SDoc
ppr Int
n

-- This is the name to go in the user-displayed string,
-- recorded in the cost centre declaration
costCentreUserName :: CostCentre -> String
costCentreUserName :: CostCentre -> String
costCentreUserName = CcName -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostCentre -> CcName
costCentreUserNameFS

costCentreUserNameFS :: CostCentre -> FastString
costCentreUserNameFS :: CostCentre -> CcName
costCentreUserNameFS (AllCafsCC {})  = String -> CcName
mkFastString String
"CAF"
costCentreUserNameFS (NormalCC {cc_name :: CostCentre -> CcName
cc_name = CcName
name, cc_flavour :: CostCentre -> CCFlavour
cc_flavour = CCFlavour
is_caf})
  =  case CCFlavour
is_caf of
      CCFlavour
CafCC -> String -> CcName
mkFastString String
"CAF:" CcName -> CcName -> CcName
`appendFS` CcName
name
      CCFlavour
_     -> CcName
name

costCentreSrcSpan :: CostCentre -> SrcSpan
costCentreSrcSpan :: CostCentre -> SrcSpan
costCentreSrcSpan = CostCentre -> SrcSpan
cc_loc

instance Binary CCFlavour where
    put_ :: BinHandle -> CCFlavour -> IO ()
put_ BinHandle
bh CCFlavour
CafCC =
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
    put_ BinHandle
bh (ExprCC CostCentreIndex
i) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CostCentreIndex
i
    put_ BinHandle
bh (DeclCC CostCentreIndex
i) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CostCentreIndex
i
    put_ BinHandle
bh (HpcCC CostCentreIndex
i) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CostCentreIndex
i
    get :: BinHandle -> IO CCFlavour
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return CCFlavour
CafCC
              Word8
1 -> CostCentreIndex -> CCFlavour
ExprCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
              Word8
2 -> CostCentreIndex -> CCFlavour
DeclCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
              Word8
_ -> CostCentreIndex -> CCFlavour
HpcCC  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

instance Binary CostCentre where
    put_ :: BinHandle -> CostCentre -> IO ()
put_ BinHandle
bh (NormalCC CCFlavour
aa CcName
ab Module
ac SrcSpan
_ad) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CCFlavour
aa
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh CcName
ab
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Module
ac
    put_ BinHandle
bh (AllCafsCC Module
ae SrcSpan
_af) = do
            BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
            forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Module
ae
    get :: BinHandle -> IO CostCentre
get BinHandle
bh = do
            Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
            case Word8
h of
              Word8
0 -> do CCFlavour
aa <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      CcName
ab <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      Module
ac <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      forall (m :: * -> *) a. Monad m => a -> m a
return (CCFlavour -> CcName -> Module -> SrcSpan -> CostCentre
NormalCC CCFlavour
aa CcName
ab Module
ac SrcSpan
noSrcSpan)
              Word8
_ -> do Module
ae <- forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
                      forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> SrcSpan -> CostCentre
AllCafsCC Module
ae SrcSpan
noSrcSpan)

    -- We ignore the SrcSpans in CostCentres when we serialise them,
    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
    -- ok, because we only need the SrcSpan when declaring the
    -- CostCentre in the original module, it is not used by importing
    -- modules.