content: {-# LANGUAGE DeriveDataTypeable #-}
  module GHC.Types.CostCentre (
          -- All abstract except to friend: ParseIface.y
          CostCentre(..), CcName, CCFlavour,
          mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour,
          mkLateCCFlavour, mkCallerCCFlavour,
          getAllCAFsCC,
  
          pprCostCentre,
          CostCentreStack,
          pprCostCentreStack,
          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 Control.DeepSeq
  
  import Data.Data
  
  -----------------------------------------------------------------------------
  -- Cost Centres
  
  -- | A Cost Centre is a single @{-# SCC #-}@ annotation.
  
  data CostCentre
    = NormalCC {
                  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.
                  cc_name :: CcName,      -- ^ Name of the cost centre itself
                  cc_mod  :: Module,      -- ^ Name of module defining this CC.
                  cc_loc  :: SrcSpan
      }
  
    | AllCafsCC {
                  cc_mod  :: Module,      -- Name of module defining this CC.
                  cc_loc  :: SrcSpan
      }
    deriving Data
  
  type CcName = FastString
  
  data IndexedCCFlavour
      = ExprCC -- ^ Explicitly annotated expression
      | DeclCC -- ^ Explicitly annotated declaration
      | HpcCC -- ^ Generated by HPC for coverage
      | LateCC -- ^ Annotated by the one of the prof-last* passes.
      | CallerCC -- ^ Annotated by the one of the prof-last* passes.
      deriving (Eq,Ord,Data,Enum)
  -- | 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, they all go into the same bucket
                 | IndexedCC !IndexedCCFlavour !CostCentreIndex -- ^ Explicitly annotated expression
                 deriving (Eq, Ord, Data)
  
  -- Construct a CC flavour
  mkCafFlavour :: CCFlavour
  mkCafFlavour = CafCC
  mkExprCCFlavour :: CostCentreIndex -> CCFlavour
  mkExprCCFlavour idx = IndexedCC ExprCC idx
  mkDeclCCFlavour :: CostCentreIndex -> CCFlavour
  mkDeclCCFlavour idx = IndexedCC DeclCC idx
  mkHpcCCFlavour :: CostCentreIndex -> CCFlavour
  mkHpcCCFlavour idx = IndexedCC HpcCC idx
  mkLateCCFlavour :: CostCentreIndex -> CCFlavour
  mkLateCCFlavour idx = IndexedCC LateCC idx
  mkCallerCCFlavour :: CostCentreIndex -> CCFlavour
  mkCallerCCFlavour idx = IndexedCC CallerCC idx
  
  -- | Extract the index from a flavour
  flavourIndex :: CCFlavour -> Int
  flavourIndex CafCC = 0
  flavourIndex (IndexedCC _flav x) = unCostCentreIndex x
  
  instance Eq CostCentre where
          c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
  
  instance Ord CostCentre where
          compare = cmpCostCentre
  
  cmpCostCentre :: CostCentre -> CostCentre -> Ordering
  
  cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2})
    = m1 `compare` m2
  
  cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}
                NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}
      -- first key is module name, then centre name, then flavour
    = mconcat
        [ m1 `compare` m2
        , n1 `lexicalCompareFS` n2 -- compare lexically to avoid non-determinism
        , f1 `compare` f2
        ]
  
  cmpCostCentre other_1 other_2
    = let
          tag1 = tag_CC other_1
          tag2 = tag_CC other_2
      in
      if tag1 < tag2 then LT else GT
    where
      tag_CC :: CostCentre -> Int
      tag_CC (NormalCC   {}) = 0
      tag_CC (AllCafsCC  {}) = 1
  
  
  -----------------------------------------------------------------------------
  -- Predicates on CostCentre
  
  isCafCC :: CostCentre -> Bool
  isCafCC (AllCafsCC {})                  = True
  isCafCC (NormalCC {cc_flavour = CafCC}) = True
  isCafCC _                               = False
  
  -- | Is this a cost-centre which records scc counts
  isSccCountCC :: CostCentre -> Bool
  isSccCountCC cc | isCafCC cc  = False
                  | otherwise   = True
  
  -- | Is this a cost-centre which can be sccd ?
  sccAbleCC :: CostCentre -> Bool
  sccAbleCC cc | isCafCC cc = False
               | otherwise  = True
  
  ccFromThisModule :: CostCentre -> Module -> Bool
  ccFromThisModule cc m = cc_mod cc == m
  
  
  -----------------------------------------------------------------------------
  -- Building cost centres
  
  mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
  mkUserCC cc_name mod loc flavour
    = NormalCC { cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
                 cc_flavour = flavour
      }
  
  mkAutoCC :: Id -> Module -> CostCentre
  mkAutoCC id mod
    = NormalCC { cc_name = str, cc_mod =  mod,
                 cc_loc = nameSrcSpan (getName id),
                 cc_flavour = CafCC
      }
    where
          name = getName 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 | isExternalName name = occNameFS (getOccName id)
              | otherwise           = concatFS [occNameFS (getOccName id),
                                                fsLit "_",
                                                mkFastString (show (getUnique name))]
  mkAllCafsCC :: Module -> SrcSpan -> CostCentre
  mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = 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 (Eq, 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 = ([], [])
  
  collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
  collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
  
  currentCCS, dontCareCCS :: CostCentreStack
  
  currentCCS              = CurrentCCS
  dontCareCCS             = DontCareCCS
  
  -----------------------------------------------------------------------------
  -- Predicates on Cost-Centre Stacks
  
  isCurrentCCS :: CostCentreStack -> Bool
  isCurrentCCS CurrentCCS                 = True
  isCurrentCCS _                          = False
  
  isCafCCS :: CostCentreStack -> Bool
  isCafCCS (SingletonCCS cc)              = isCafCC cc
  isCafCCS _                              = False
  
  maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
  maybeSingletonCCS (SingletonCCS cc)     = Just cc
  maybeSingletonCCS _                     = Nothing
  
  mkSingletonCCS :: CostCentre -> CostCentreStack
  mkSingletonCCS cc = SingletonCCS cc
  
  
  -----------------------------------------------------------------------------
  -- Printing Cost Centre Stacks.
  
  -- The outputable instance for CostCentreStack prints the CCS as a C
  -- expression.
  
  instance Outputable CostCentreStack where
    ppr = pprCostCentreStack
  
  pprCostCentreStack :: IsLine doc => CostCentreStack -> doc
  pprCostCentreStack CurrentCCS        = text "CCCS"
  pprCostCentreStack DontCareCCS       = text "CCS_DONT_CARE"
  pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs"
  {-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-}
  {-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
  
  -----------------------------------------------------------------------------
  -- 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 = pprCostCentre
  
  pprCostCentre :: IsLine doc => CostCentre -> doc
  pprCostCentre cc = docWithStyle (ppCostCentreLbl cc)
                                  (\_ -> ftext (costCentreUserNameFS cc))
  {-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-}
  {-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
  
  -- Printing in Core
  pprCostCentreCore :: CostCentre -> SDoc
  pprCostCentreCore (AllCafsCC {cc_mod = m})
    = text "__sccC" <+> braces (ppr m)
  pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
                               cc_mod = m, cc_loc = loc})
    = text "__scc" <+> braces (hsep [
          ppr m <> char '.' <> ftext n,
          pprFlavourCore flavour,
          whenPprDebug (ppr loc)
      ])
  
  -- ^ Print a flavour in Core
  pprFlavourCore :: CCFlavour -> SDoc
  pprFlavourCore CafCC = text "__C"
  pprFlavourCore f     = pprIdxCore $ flavourIndex f
  
  -- ^ Print a flavour's index in Core
  pprIdxCore :: Int -> SDoc
  pprIdxCore 0 = empty
  pprIdxCore idx = whenPprDebug $ ppr idx
  
  -- Printing as a C label
  ppCostCentreLbl :: IsLine doc => CostCentre -> doc
  ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = pprModule m <> text "_CAFs_cc"
  ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
    = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
          ppFlavourLblComponent f <> text "_cc"
  {-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-}
  {-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
  
  -- ^ Print the flavour component of a C label
  ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc
  ppFlavourLblComponent CafCC = text "CAF"
  ppFlavourLblComponent (IndexedCC flav i) =
    case flav of
      ExprCC -> text "EXPR" <> ppIdxLblComponent i
      DeclCC -> text "DECL" <> ppIdxLblComponent i
      HpcCC -> text "HPC" <> ppIdxLblComponent i
      LateCC -> text "LATECC" <> ppIdxLblComponent i
      CallerCC -> text "CALLERCC" <> ppIdxLblComponent i
  {-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-}
  {-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
  
  -- ^ Print the flavour index component of a C label
  ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc
  ppIdxLblComponent n =
    case unCostCentreIndex n of
      0 -> empty
      n -> int n
  {-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-}
  {-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
  
  -- This is the name to go in the user-displayed string,
  -- recorded in the cost centre declaration
  costCentreUserName :: CostCentre -> String
  costCentreUserName = unpackFS . costCentreUserNameFS
  
  costCentreUserNameFS :: CostCentre -> FastString
  costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
  costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
    =  case is_caf of
        CafCC -> mkFastString "CAF:" `appendFS` name
        _     -> name
  
  costCentreSrcSpan :: CostCentre -> SrcSpan
  costCentreSrcSpan = cc_loc
  
  instance Binary CCFlavour where
      put_ bh CafCC =
          putByte bh 0
      put_ bh (IndexedCC flav i) = do
          putByte bh 1
          let !flav_index = fromEnum flav
          put_ bh flav_index
          put_ bh i
      get bh = do
              h <- getByte bh
              case h of
                0 -> return CafCC
                _ -> do
                  IndexedCC <$> (toEnum <$> get bh) <*> get bh
  
  instance Binary CostCentre where
      put_ bh (NormalCC aa ab ac _ad) = do
              putByte bh 0
              put_ bh aa
              put_ bh ab
              put_ bh ac
      put_ bh (AllCafsCC ae _af) = do
              putByte bh 1
              put_ bh ae
      get bh = do
              h <- getByte bh
              case h of
                0 -> do aa <- get bh
                        ab <- get bh
                        ac <- get bh
                        return (NormalCC aa ab ac noSrcSpan)
                _ -> do ae <- get bh
                        return (AllCafsCC ae 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.
  
  instance NFData CostCentre where
    rnf (NormalCC aa ab ac ad) = rnf aa `seq` rnf ab `seq` rnf ac `seq` rnf ad
    rnf (AllCafsCC ae ad) = rnf ae `seq` rnf ad
  
  instance NFData CCFlavour where
    rnf CafCC = ()
    rnf (IndexedCC flav i) = rnf flav `seq` rnf i
  
  instance NFData IndexedCCFlavour where
    rnf ExprCC = ()
    rnf DeclCC = ()
    rnf HpcCC = ()
    rnf LateCC = ()
    rnf CallerCC = ()
  
  getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
  getAllCAFsCC this_mod =
      let
        span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
        all_cafs_cc  = mkAllCafsCC this_mod span
        all_cafs_ccs = mkSingletonCCS all_cafs_cc
      in
        (all_cafs_cc, all_cafs_ccs)
  
  