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

2 files changed, 119 insertions, 48 deletions

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)