Fix CallerCC potentially shadowing other cost centres.wip/andreask/callercc

Add a CallerCC cost centre flavour for cost centres added by the
CallerCC pass. This avoids potential accidental shadowing between
CCs added by user annotations and ones added by CallerCC.

6 files changed, 49 insertions, 40 deletions

diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs
index 7a677e9964..9a2d43a9cb 100644
--- a/compiler/GHC/Core/LateCC.hs
+++ b/compiler/GHC/Core/LateCC.hs
@@ -142,7 +142,7 @@ initLateCCState :: LateCCState
 initLateCCState = LateCCState newCostCentreState mempty
 
 getCCFlavour :: FastString -> M CCFlavour
-getCCFlavour name = LateCC <$> getCCIndex' name
+getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name
 
 getCCIndex' :: FastString -> M CostCentreIndex
 getCCIndex' name = do
diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs
index 1bdb4d7afc..4218ebbac9 100644
--- a/compiler/GHC/Core/Opt/CallerCC.hs
+++ b/compiler/GHC/Core/Opt/CallerCC.hs
@@ -84,7 +84,7 @@ doExpr env e@(Var v)
         span = case revParents env of
           top:_ -> nameSrcSpan $ varName top
           _     -> noSrcSpan
-        cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span
+        cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span
         tick :: CoreTickish
         tick = ProfNote cc count True
     pure $ Tick tick e
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index da3d1f4dac..d106899835 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -538,7 +538,7 @@ ds_prag_expr (HsPragSCC _ cc) expr = do
         mod_name <- getModule
         count <- goptM Opt_ProfCountEntries
         let nm = sl_fs cc
-        flavour <- ExprCC <$> getCCIndexDsM nm
+        flavour <- mkExprCCFlavour <$> getCCIndexDsM nm
         Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
                <$> dsLExpr expr
       else dsLExpr expr
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index 43a12e5ed8..3ccf46c4cf 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -1189,7 +1189,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
 
     ProfNotes -> do
       let nm = mkFastString cc_name
-      flavour <- HpcCC <$> getCCIndexM nm
+      flavour <- mkHpcCCFlavour <$> getCCIndexM nm
       let cc = mkUserCC nm (this_mod env) pos flavour
           count = countEntries && tte_countEntries env
       return $ ProfNote cc count True{-scopes-}
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index c4269c984d..c957fc7fcd 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -28,7 +28,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr  ( tcCheckMonoExpr )
 import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
 
 import GHC.Types.Tickish (CoreTickish, GenTickish (..))
-import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
+import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour)
 import GHC.Driver.Session
 import GHC.Data.FastString
 import GHC.Hs
@@ -677,7 +677,7 @@ funBindTicks loc fun_id mod sigs
           = getOccFS (Var.varName fun_id)
         cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str]
   = do
-      flavour <- DeclCC <$> getCCIndexTcM cc_name
+      flavour <- mkDeclCCFlavour <$> getCCIndexTcM cc_name
       let cc = mkUserCC cc_name mod loc flavour
       return [ProfNote cc True True]
   | otherwise
diff --git a/compiler/GHC/Types/CostCentre.hs b/compiler/GHC/Types/CostCentre.hs
index a41496f83c..e65a622b75 100644
--- a/compiler/GHC/Types/CostCentre.hs
+++ b/compiler/GHC/Types/CostCentre.hs
@@ -1,7 +1,9 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module GHC.Types.CostCentre (
-        CostCentre(..), CcName, CCFlavour(..),
-                -- All abstract except to friend: ParseIface.y
+        -- All abstract except to friend: ParseIface.y
+        CostCentre(..), CcName, CCFlavour,
+        mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour,
+        mkLateCCFlavour, mkCallerCCFlavour,
 
         pprCostCentre,
         CostCentreStack,
@@ -33,7 +35,6 @@ import GHC.Utils.Outputable
 import GHC.Types.SrcLoc
 import GHC.Data.FastString
 import GHC.Types.CostCentre.State
-import GHC.Utils.Panic.Plain
 
 import Data.Data
 
@@ -66,24 +67,39 @@ data CostCentre
 
 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
-               | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression
-               | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration
-               | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage
-               | LateCC !CostCentreIndex -- ^ Annotated by the one of the prof-last* passes.
+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 (ExprCC x) = unCostCentreIndex x
-flavourIndex (DeclCC x) = unCostCentreIndex x
-flavourIndex (HpcCC x) = unCostCentreIndex x
-flavourIndex (LateCC x) = unCostCentreIndex x
+flavourIndex (IndexedCC _flav x) = unCostCentreIndex x
 
 instance Eq CostCentre where
         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
@@ -304,10 +320,13 @@ ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
 -- ^ Print the flavour component of a C label
 ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc
 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
-ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i
+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
 
@@ -337,28 +356,18 @@ costCentreSrcSpan = cc_loc
 
 instance Binary CCFlavour where
     put_ bh CafCC =
-            putByte bh 0
-    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
-    put_ bh (LateCC i) = do
-            putByte bh 4
-            put_ bh i
+        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
-              1 -> ExprCC <$> get bh
-              2 -> DeclCC <$> get bh
-              3 -> HpcCC  <$> get bh
-              4 -> LateCC <$> get bh
-              _ -> panic "Invalid CCFlavour"
+              _ -> do
+                IndexedCC <$> (toEnum <$> get bh) <*> get bh
 
 instance Binary CostCentre where
     put_ bh (NormalCC aa ab ac _ad) = do