content: {-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
  module Eta.Profiling.CostCentre (
          CostCentre(..), CcName, IsCafCC(..),
                  -- All abstract except to friend: ParseIface.y
  
          CostCentreStack,
          CollectedCCs,
          noCCS, currentCCS, dontCareCCS,
          noCCSAttached, 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 Eta.Utils.Binary
  import Eta.BasicTypes.Var
  import Eta.BasicTypes.Name
  import Eta.BasicTypes.Module
  import Eta.BasicTypes.Unique
  import Eta.Utils.Outputable
  import Eta.Utils.FastTypes
  import Eta.BasicTypes.SrcLoc
  import Eta.Utils.FastString
  import Eta.Utils.Util
  
  import Data.Data
  
  -----------------------------------------------------------------------------
  -- Cost Centres
  
  -- | A Cost Centre is a single @{-# SCC #-}@ annotation.
  
  data CostCentre
    = NormalCC {
                  cc_key  :: {-# UNPACK #-} !Int,
                   -- ^ 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 a
                   -- Unique that is distinct from every other
                   -- CostCentre in the same module.
                   --
                   -- XXX: should really be using Unique here, but we
                   -- need to derive Data below and there's no Data
                   -- instance for Unique.
                  cc_name :: CcName,      -- ^ Name of the cost centre itself
                  cc_mod  :: Module,      -- ^ Name of module defining this CC.
                  cc_loc  :: SrcSpan,
                  cc_is_caf  :: IsCafCC   -- see below
      }
  
    | AllCafsCC {
                  cc_mod  :: Module,      -- Name of module defining this CC.
                  cc_loc  :: SrcSpan
      }
    deriving (Data, Typeable)
  
  type CcName = FastString
  
  data IsCafCC = NotCafCC | CafCC
    deriving (Eq, Ord, Data, Typeable)
  
  
  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_key = n1, cc_mod =  m1}
                NormalCC {cc_key = n2, cc_mod =  m2}
      -- first key is module name, then the integer key
    = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
  
  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 (NormalCC   {}) = _ILIT(0)
      tag_CC (AllCafsCC  {}) = _ILIT(1)
  
  
  -----------------------------------------------------------------------------
  -- Predicates on CostCentre
  
  isCafCC :: CostCentre -> Bool
  isCafCC (AllCafsCC {})                 = True
  isCafCC (NormalCC {cc_is_caf = 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 -> Unique -> CostCentre
  mkUserCC cc_name mod loc key
    = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod =  mod, cc_loc = loc,
                 cc_is_caf = NotCafCC {-might be changed-}
      }
  
  mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
  mkAutoCC id mod is_caf
    = NormalCC { cc_key = getKey (getUnique id),
                 cc_name = str, cc_mod =  mod,
                 cc_loc = nameSrcSpan (getName id),
                 cc_is_caf = is_caf
      }
    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           = occNameFS (getOccName id)
                                      `appendFS`
                                      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
    = NoCCS
  
    | 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
      , [CostCentre]       -- "extern" cost-centres
      , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
      )
  
  
  noCCS, currentCCS, dontCareCCS :: CostCentreStack
  
  noCCS                   = NoCCS
  currentCCS              = CurrentCCS
  dontCareCCS             = DontCareCCS
  
  -----------------------------------------------------------------------------
  -- Predicates on Cost-Centre Stacks
  
  noCCSAttached :: CostCentreStack -> Bool
  noCCSAttached NoCCS                     = True
  noCCSAttached _                         = False
  
  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 NoCCS             = ptext (sLit "NO_CCS")
    ppr CurrentCCS        = ptext (sLit "CCCS")
    ppr DontCareCCS       = ptext (sLit "CCS_DONT_CARE")
    ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_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 cc = getPprStyle $ \ sty ->
             if codeStyle sty
             then ppCostCentreLbl cc
             else text (costCentreUserName cc)
  
  -- Printing in Core
  pprCostCentreCore :: CostCentre -> SDoc
  pprCostCentreCore (AllCafsCC {cc_mod = m})
    = text "__sccC" <+> braces (ppr m)
  pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
                               cc_is_caf = caf})
    = text "__scc" <+> braces (hsep [
          ppr m <> char '.' <> ftext n,
          ifPprDebug (ppr key),
          pp_caf caf,
          ifPprDebug (ppr loc)
      ])
  
  pp_caf :: IsCafCC -> SDoc
  pp_caf CafCC = text "__C"
  pp_caf _     = empty
  
  -- Printing as a C label
  ppCostCentreLbl :: CostCentre -> SDoc
  ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
  ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
                             cc_is_caf = is_caf})
    = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
          case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
  
  -- 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_is_caf = is_caf})
    =  case is_caf of
        CafCC -> mkFastString "CAF:" `appendFS` name
        _     -> name
  
  costCentreSrcSpan :: CostCentre -> SrcSpan
  costCentreSrcSpan = cc_loc
  
  instance Binary IsCafCC where
      put_ bh CafCC = do
              putByte bh 0
      put_ bh NotCafCC = do
              putByte bh 1
      get bh = do
              h <- getByte bh
              case h of
                0 -> do return CafCC
                _ -> do return NotCafCC
  
  instance Binary CostCentre where
      put_ bh (NormalCC aa ab ac _ad ae) = do
              putByte bh 0
              put_ bh aa
              put_ bh ab
              put_ bh ac
              put_ bh ae
      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
                        ae <- get bh
                        return (NormalCC aa ab ac noSrcSpan ae)
                _ -> 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.
  