Make cost centre symbol names deterministic.

Previously, non-CAF cost centre symbol names contained a unique,
leading to non-deterministic object files which, among other issues,
can lead to an inconsistency causing linking failure when using cached
builds sourced from multiple machines, such as with nix. Now, each
cost centre symbol is annotated with the type of cost centre it
is (CAF, expression annotation, declaration annotation, or HPC) and,
when a single module has multiple cost centres with the same name and
type, a 0-based index.

Reviewers: bgamari, simonmar

Reviewed By: bgamari

Subscribers: niteria, simonmar, RyanGlScott, osa1, rwbarton, thomie, carter

GHC Trac Issues: #4012, #12935

Differential Revision: https://phabricator.haskell.org/D4388

10 files changed, 188 insertions, 75 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index b2e9ea2cf6..1c118a84b6 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -27,6 +27,7 @@ import NameSet hiding (FreeVars)
 import Name
 import Bag
 import CostCentre
+import CostCentreState
 import CoreSyn
 import Id
 import VarSet
@@ -34,7 +35,6 @@ import Data.List
 import FastString
 import HscTypes
 import TyCon
-import UniqSupply
 import BasicTypes
 import MonadUtils
 import Maybes
@@ -75,7 +75,6 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
     Just orig_file <- ml_hs_file mod_loc,
     not ("boot" `isSuffixOf` orig_file) = do
 
-     us <- mkSplitUniqSupply 'C' -- for cost centres
      let  orig_file2 = guessSourceFile binds orig_file
 
           tickPass tickish (binds,st) =
@@ -98,7 +97,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
 
           initState = TT { tickBoxCount = 0
                          , mixEntries   = []
-                         , uniqSupply   = us
+                         , ccIndices    = newCostCentreState
                          }
 
           (binds1,st) = foldr tickPass (binds, initState) passes
@@ -1002,7 +1001,7 @@ liftL f (L loc a) = do
 
 data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry_]
-                         , uniqSupply  :: UniqSupply
+                         , ccIndices   :: CostCentreState
                          }
 
 data TickTransEnv = TTE { fileName     :: FastString
@@ -1077,10 +1076,11 @@ instance Monad TM where
 instance HasDynFlags TM where
   getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
 
-instance MonadUnique TM where
-  getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)
-  getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)
-                             in (u, noFVs, st { uniqSupply = us' })
+-- | Get the next HPC cost centre index for a given centre name
+getCCIndexM :: FastString -> TM CostCentreIndex
+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
+                                                 ccIndices st
+                              in (idx, noFVs, st { ccIndices = is' })
 
 getState :: TM TickTransState
 getState = TM $ \ _ st -> (st, noFVs, st)
@@ -1208,8 +1208,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
       return $ HpcTick (this_mod env) c
 
     ProfNotes -> do
-      ccUnique <- getUniqueM
-      let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique
+      let nm = mkFastString cc_name
+      flavour <- HpcCC <$> getCCIndexM nm
+      let cc = mkUserCC nm (this_mod env) pos flavour
           count = countEntries && gopt Opt_ProfCountEntries dflags
       return $ ProfNote cc count True{-scopes-}
 
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 2f3739e4c2..0b439a14b2 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -392,8 +392,9 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
       then do
         mod_name <- getModule
         count <- goptM Opt_ProfCountEntries
-        uniq <- newUnique
-        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
                <$> dsLExpr expr
       else dsLExpr expr
 
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index ae39e3de5a..d075d0a118 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -91,6 +91,7 @@ import Var (EvVar)
 import qualified GHC.LanguageExtensions as LangExt
 import UniqFM ( lookupWithDefaultUFM )
 import Literal ( mkMachString )
+import CostCentreState
 
 import Data.IORef
 import Control.Monad
@@ -182,6 +183,7 @@ mkDsEnvsFromTcGbl :: MonadIO m
                   -> m (DsGblEnv, DsLclEnv)
 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
   = do { pm_iter_var <- liftIO $ newIORef 0
+       ; cc_st_var   <- liftIO $ newIORef newCostCentreState
        ; let dflags   = hsc_dflags hsc_env
              this_mod = tcg_mod tcg_env
              type_env = tcg_type_env tcg_env
@@ -190,7 +192,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
              complete_matches = hptCompleteSigs hsc_env
                                 ++ tcg_complete_matches tcg_env
        ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
-                           msg_var pm_iter_var complete_matches
+                           msg_var pm_iter_var cc_st_var complete_matches
        }
 
 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
@@ -210,6 +212,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside
 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
 initDsWithModGuts hsc_env guts thing_inside
   = do { pm_iter_var <- newIORef 0
+       ; cc_st_var   <- newIORef newCostCentreState
        ; msg_var <- newIORef emptyMessages
        ; let dflags   = hsc_dflags hsc_env
              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
@@ -225,7 +228,7 @@ initDsWithModGuts hsc_env guts thing_inside
 
              envs  = mkDsEnvs dflags this_mod rdr_env type_env
                               fam_inst_env msg_var pm_iter_var
-                              complete_matches
+                              cc_st_var complete_matches
        ; runDs hsc_env envs thing_inside
        }
 
@@ -253,9 +256,9 @@ initTcDsForSolver thing_inside
          thing_inside }
 
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> IORef Messages -> IORef Int -> [CompleteMatch]
-         -> (DsGblEnv, DsLclEnv)
-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
+         -> IORef Messages -> IORef Int -> IORef CostCentreState
+         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
          complete_matches
   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
                              if_rec_types = Just (mod, return type_env) }
@@ -271,6 +274,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
                            , ds_dph_env = emptyGlobalRdrEnv
                            , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
                            , ds_complete_matches = completeMatchMap
+                           , ds_cc_st   = cc_st_var
                            }
         lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                            , dsl_loc     = real_span
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 384a50ff7e..5ffc3cebfd 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -390,6 +390,7 @@ Library
         TysPrim
         TysWiredIn
         CostCentre
+        CostCentreState
         ProfInit
         RnBinds
         RnEnv
diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs
index 0043fd4bbc..91a4ef0ec7 100644
--- a/compiler/profiling/CostCentre.hs
+++ b/compiler/profiling/CostCentre.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module CostCentre (
-        CostCentre(..), CcName, IsCafCC(..),
+        CostCentre(..), CcName, CCFlavour(..),
                 -- All abstract except to friend: ParseIface.y
 
         CostCentreStack,
@@ -31,6 +31,7 @@ import Outputable
 import SrcLoc
 import FastString
 import Util
+import CostCentreState
 
 import Data.Data
 
@@ -41,21 +42,18 @@ import Data.Data
 
 data CostCentre
   = NormalCC {
-                cc_key  :: {-# UNPACK #-} !Int,
+                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 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.
+                 -- 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,
-                cc_is_caf  :: IsCafCC   -- see below
+                cc_loc  :: SrcSpan
     }
 
   | AllCafsCC {
@@ -66,9 +64,22 @@ data CostCentre
 
 type CcName = FastString
 
-data IsCafCC = NotCafCC | CafCC
-  deriving (Eq, Ord, Data)
-
+-- | 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 (Eq, Ord, Data)
+
+-- | Extract the index from a flavour
+flavourIndex :: CCFlavour -> Int
+flavourIndex CafCC = 0
+flavourIndex (ExprCC x) = unCostCentreIndex x
+flavourIndex (DeclCC x) = unCostCentreIndex x
+flavourIndex (HpcCC x) = unCostCentreIndex x
 
 instance Eq CostCentre where
         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
@@ -81,10 +92,10 @@ 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 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
+  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
 
 cmpCostCentre other_1 other_2
   = let
@@ -102,9 +113,9 @@ cmpCostCentre other_1 other_2
 -- Predicates on CostCentre
 
 isCafCC :: CostCentre -> Bool
-isCafCC (AllCafsCC {})                 = True
-isCafCC (NormalCC {cc_is_caf = CafCC}) = True
-isCafCC _                              = False
+isCafCC (AllCafsCC {})                  = True
+isCafCC (NormalCC {cc_flavour = CafCC}) = True
+isCafCC _                               = False
 
 -- | Is this a cost-centre which records scc counts
 isSccCountCC :: CostCentre -> Bool
@@ -123,18 +134,17 @@ 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-}
+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 -> IsCafCC -> CostCentre
-mkAutoCC id mod is_caf
-  = NormalCC { cc_key = getKey (getUnique id),
-               cc_name = str, cc_mod =  mod,
+mkAutoCC :: Id -> Module -> CostCentre
+mkAutoCC id mod
+  = NormalCC { cc_name = str, cc_mod =  mod,
                cc_loc = nameSrcSpan (getName id),
-               cc_is_caf = is_caf
+               cc_flavour = CafCC
     }
   where
         name = getName id
@@ -249,26 +259,44 @@ instance Outputable CostCentre where
 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})
+pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
+                             cc_mod = m, cc_loc = loc})
   = text "__scc" <+> braces (hsep [
         ppr m <> char '.' <> ftext n,
-        whenPprDebug (ppr key),
-        pp_caf caf,
+        pprFlavourCore flavour,
         whenPprDebug (ppr loc)
     ])
 
-pp_caf :: IsCafCC -> SDoc
-pp_caf CafCC = text "__C"
-pp_caf _     = empty
+-- ^ 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 :: 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})
+ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
   = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
-        case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
+        ppFlavourLblComponent f <> text "_cc"
+
+-- ^ Print the flavour component of a C label
+ppFlavourLblComponent :: CCFlavour -> SDoc
+ppFlavourLblComponent CafCC = text "CAF"
+ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
+ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
+ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
+
+-- ^ Print the flavour index component of a C label
+ppIdxLblComponent :: CostCentreIndex -> SDoc
+ppIdxLblComponent n =
+  case unCostCentreIndex n of
+    0 -> empty
+    n -> ppr n
 
 -- This is the name to go in the user-displayed string,
 -- recorded in the cost centre declaration
@@ -277,7 +305,7 @@ costCentreUserName = unpackFS . costCentreUserNameFS
 
 costCentreUserNameFS :: CostCentre -> FastString
 costCentreUserNameFS (AllCafsCC {})  = mkFastString "CAF"
-costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
+costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
   =  case is_caf of
       CafCC -> mkFastString "CAF:" `appendFS` name
       _     -> name
@@ -285,24 +313,32 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
 costCentreSrcSpan :: CostCentre -> SrcSpan
 costCentreSrcSpan = cc_loc
 
-instance Binary IsCafCC where
+instance Binary CCFlavour where
     put_ bh CafCC = do
             putByte bh 0
-    put_ bh NotCafCC = do
+    put_ bh (ExprCC i) = do
             putByte bh 1
+            put_ bh i
+    put_ bh (DeclCC i) = do
+            putByte bh 2
+            put_ bh i
+    put_ bh (HpcCC i) = do
+            putByte bh 3
+            put_ bh i
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CafCC
-              _ -> do return NotCafCC
+              1 -> ExprCC <$> get bh
+              2 -> DeclCC <$> get bh
+              _ -> HpcCC <$> get bh
 
 instance Binary CostCentre where
-    put_ bh (NormalCC aa ab ac _ad ae) = do
+    put_ bh (NormalCC aa ab ac _ad) = 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
@@ -312,8 +348,7 @@ instance Binary CostCentre where
               0 -> do aa <- get bh
                       ab <- get bh
                       ac <- get bh
-                      ae <- get bh
-                      return (NormalCC aa ab ac noSrcSpan ae)
+                      return (NormalCC aa ab ac noSrcSpan)
               _ -> do ae <- get bh
                       return (AllCafsCC ae noSrcSpan)
 
diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs
new file mode 100644
index 0000000000..0050c1d033
--- /dev/null
+++ b/compiler/profiling/CostCentreState.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module CostCentreState ( CostCentreState, newCostCentreState
+                       , CostCentreIndex, unCostCentreIndex, getCCIndex
+                       ) where
+
+import GhcPrelude
+import FastString
+import FastStringEnv
+
+import Data.Data
+import Binary
+
+-- | Per-module state for tracking cost centre indices.
+--
+-- See documentation of 'CostCentre.cc_flavour' for more details.
+newtype CostCentreState = CostCentreState (FastStringEnv Int)
+
+-- | Initialize cost centre state.
+newCostCentreState :: CostCentreState
+newCostCentreState = CostCentreState emptyFsEnv
+
+-- | An index into a given cost centre module,name,flavour set
+newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int }
+  deriving (Eq, Ord, Data, Binary)
+
+-- | Get a new index for a given cost centre name.
+getCCIndex :: FastString
+           -> CostCentreState
+           -> (CostCentreIndex, CostCentreState)
+getCCIndex nm (CostCentreState m) =
+    (CostCentreIndex idx, CostCentreState m')
+  where
+    m_idx = lookupFsEnv m nm
+    idx = maybe 0 id m_idx
+    m' = extendFsEnv m nm (idx + 1)
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 671f3eb5b5..f85382bc55 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -803,7 +803,7 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
              | otherwise                      = Updatable
 
     -- CAF cost centres generated for -fcaf-all
-    caf_cc = mkAutoCC bndr modl CafCC
+    caf_cc = mkAutoCC bndr modl
     caf_ccs = mkSingletonCCS caf_cc
            -- careful: the binder might be :Main.main,
            -- which doesn't belong to module mod_name.
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 0c5179c473..60ed962bae 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -22,7 +22,7 @@ import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
                                , tcPatSynBuilderBind )
 import CoreSyn (Tickish (..))
-import CostCentre (mkUserCC)
+import CostCentre (mkUserCC, CCFlavour(DeclCC))
 import DynFlags
 import FastString
 import HsSyn
@@ -62,7 +62,6 @@ import BasicTypes
 import Outputable
 import PrelNames( ipClassName )
 import TcValidity (checkValidType)
-import Unique (getUnique)
 import UniqFM
 import UniqSet
 import qualified GHC.LanguageExtensions as LangExt
@@ -714,11 +713,12 @@ tcPolyCheck prag_fn
        ; poly_id    <- addInlinePrags poly_id prag_sigs
 
        ; mod <- getModule
+       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
        ; let bind' = FunBind { fun_id      = L nm_loc mono_id
                              , fun_matches = matches'
                              , fun_co_fn   = co_fn
                              , bind_fvs    = placeHolderNamesTc
-                             , fun_tick    = funBindTicks nm_loc mono_id mod prag_sigs }
+                             , fun_tick    = tick }
 
              export = ABE { abe_wrap = idHsWrapper
                           , abe_poly  = poly_id
@@ -739,7 +739,7 @@ tcPolyCheck _prag_fn sig bind
   = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
 
 funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-             -> [Tickish TcId]
+             -> TcM [Tickish TcId]
 funBindTicks loc fun_id mod sigs
   | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
       -- this can only be a singleton list, as duplicate pragmas are rejected
@@ -750,10 +750,12 @@ funBindTicks loc fun_id mod sigs
           | otherwise
           = getOccFS (Var.varName fun_id)
         cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
-        cc = mkUserCC cc_name mod loc (getUnique fun_id)
-  = [ProfNote cc True True]
+  = do
+      flavour <- DeclCC <$> getCCIndexM cc_name
+      let cc = mkUserCC cc_name mod loc flavour
+      return [ProfNote cc True True]
   | otherwise
-  = []
+  = return []
 
 {- Note [Instantiate sig with fresh variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 184093f066..20185aebe1 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -128,6 +128,9 @@ module TcRnMonad(
 
   withException,
 
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
   -- * Types etc.
   module TcRnTypes,
   module IOEnv
@@ -170,6 +173,7 @@ import Util
 import Annotations
 import BasicTypes( TopLevelFlag )
 import Maybes
+import CostCentreState
 
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -217,6 +221,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 
         dependent_files_var <- newIORef [] ;
         static_wc_var       <- newIORef emptyWC ;
+        cc_st_var           <- newIORef newCostCentreState ;
         th_topdecls_var      <- newIORef [] ;
         th_foreign_files_var <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
@@ -302,7 +307,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_tc_plugins     = [],
                 tcg_top_loc        = loc,
                 tcg_static_wc      = static_wc_var,
-                tcg_complete_matches = []
+                tcg_complete_matches = [],
+                tcg_cc_st          = cc_st_var
              } ;
         } ;
 
@@ -1872,3 +1878,24 @@ up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
 discussion).  We don't currently know a general solution to this problem, but
 we can use uninterruptibleMask_ to avoid the situation.
 -}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+  extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+  extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+  extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+            => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+  env <- getGblEnv
+  let cc_st_ref = extractCostCentreState env
+  cc_st <- readTcRef cc_st_ref
+  let (idx, cc_st') = getCCIndex nm cc_st
+  writeTcRef cc_st_ref cc_st'
+  return idx
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 4b11fa6114..27482b1841 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -189,6 +189,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import Fingerprint
 import Util
 import PrelNames ( isUnboundName )
+import CostCentreState
 
 import Control.Monad (ap, liftM, msum)
 import qualified Control.Monad.Fail as MonadFail
@@ -394,6 +395,8 @@ data DsGblEnv
         , ds_parr_bi :: PArrBuiltin             -- desugarer names for '-XParallelArrays'
         , ds_complete_matches :: CompleteMatchMap
            -- Additional complete pattern matches
+        , ds_cc_st   :: IORef CostCentreState
+           -- Tracking indices for cost centre annotations
         }
 
 instance ContainsModule DsGblEnv where
@@ -700,7 +703,10 @@ data TcGblEnv
         tcg_static_wc :: TcRef WantedConstraints,
           -- ^ Wanted constraints of static forms.
         -- See Note [Constraints in static forms].
-        tcg_complete_matches :: [CompleteMatch]
+        tcg_complete_matches :: [CompleteMatch],
+
+        -- ^ Tracking indices for cost centre annotations
+        tcg_cc_st   :: TcRef CostCentreState
     }
 
 -- NB: topModIdentity, not topModSemantic!