[Git][ghc/ghc][master] Fix CallerCC potentially shadowing other cost centres.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Feb 3 19:08:27 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
bf3f88a1 by Andreas Klebinger at 2023-02-03T14:08:07-05:00
Fix CallerCC potentially shadowing other cost centres.
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 changed files:
- compiler/GHC/Core/LateCC.hs
- compiler/GHC/Core/Opt/CallerCC.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Types/CostCentre.hs
Changes:
=====================================
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
=====================================
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
=====================================
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
=====================================
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-}
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf3f88a1a5b23bdf304baca473c3ee797c5f86bd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf3f88a1a5b23bdf304baca473c3ee797c5f86bd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230203/adbd3481/attachment-0001.html>
More information about the ghc-commits
mailing list