Commit d8e47a2e authored by shlevy's avatar shlevy Committed by Ben Gamari

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
parent f8e3cd3b
...@@ -27,6 +27,7 @@ import NameSet hiding (FreeVars) ...@@ -27,6 +27,7 @@ import NameSet hiding (FreeVars)
import Name import Name
import Bag import Bag
import CostCentre import CostCentre
import CostCentreState
import CoreSyn import CoreSyn
import Id import Id
import VarSet import VarSet
...@@ -34,7 +35,6 @@ import Data.List ...@@ -34,7 +35,6 @@ import Data.List
import FastString import FastString
import HscTypes import HscTypes
import TyCon import TyCon
import UniqSupply
import BasicTypes import BasicTypes
import MonadUtils import MonadUtils
import Maybes import Maybes
...@@ -75,7 +75,6 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds ...@@ -75,7 +75,6 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
Just orig_file <- ml_hs_file mod_loc, Just orig_file <- ml_hs_file mod_loc,
not ("boot" `isSuffixOf` orig_file) = do not ("boot" `isSuffixOf` orig_file) = do
us <- mkSplitUniqSupply 'C' -- for cost centres
let orig_file2 = guessSourceFile binds orig_file let orig_file2 = guessSourceFile binds orig_file
tickPass tickish (binds,st) = tickPass tickish (binds,st) =
...@@ -98,7 +97,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds ...@@ -98,7 +97,7 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
initState = TT { tickBoxCount = 0 initState = TT { tickBoxCount = 0
, mixEntries = [] , mixEntries = []
, uniqSupply = us , ccIndices = newCostCentreState
} }
(binds1,st) = foldr tickPass (binds, initState) passes (binds1,st) = foldr tickPass (binds, initState) passes
...@@ -1002,7 +1001,7 @@ liftL f (L loc a) = do ...@@ -1002,7 +1001,7 @@ liftL f (L loc a) = do
data TickTransState = TT { tickBoxCount:: Int data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry_] , mixEntries :: [MixEntry_]
, uniqSupply :: UniqSupply , ccIndices :: CostCentreState
} }
data TickTransEnv = TTE { fileName :: FastString data TickTransEnv = TTE { fileName :: FastString
...@@ -1077,10 +1076,11 @@ instance Monad TM where ...@@ -1077,10 +1076,11 @@ instance Monad TM where
instance HasDynFlags TM where instance HasDynFlags TM where
getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st) getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
instance MonadUnique TM where -- | Get the next HPC cost centre index for a given centre name
getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st) getCCIndexM :: FastString -> TM CostCentreIndex
getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st) getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
in (u, noFVs, st { uniqSupply = us' }) ccIndices st
in (idx, noFVs, st { ccIndices = is' })
getState :: TM TickTransState getState :: TM TickTransState
getState = TM $ \ _ st -> (st, noFVs, st) getState = TM $ \ _ st -> (st, noFVs, st)
...@@ -1208,8 +1208,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do ...@@ -1208,8 +1208,9 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
return $ HpcTick (this_mod env) c return $ HpcTick (this_mod env) c
ProfNotes -> do ProfNotes -> do
ccUnique <- getUniqueM let nm = mkFastString cc_name
let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique flavour <- HpcCC <$> getCCIndexM nm
let cc = mkUserCC nm (this_mod env) pos flavour
count = countEntries && gopt Opt_ProfCountEntries dflags count = countEntries && gopt Opt_ProfCountEntries dflags
return $ ProfNote cc count True{-scopes-} return $ ProfNote cc count True{-scopes-}
......
...@@ -392,8 +392,9 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do ...@@ -392,8 +392,9 @@ ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
then do then do
mod_name <- getModule mod_name <- getModule
count <- goptM Opt_ProfCountEntries count <- goptM Opt_ProfCountEntries
uniq <- newUnique let nm = sl_fs cc
Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True) flavour <- ExprCC <$> getCCIndexM nm
Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
<$> dsLExpr expr <$> dsLExpr expr
else dsLExpr expr else dsLExpr expr
......
...@@ -91,6 +91,7 @@ import Var (EvVar) ...@@ -91,6 +91,7 @@ import Var (EvVar)
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
import UniqFM ( lookupWithDefaultUFM ) import UniqFM ( lookupWithDefaultUFM )
import Literal ( mkMachString ) import Literal ( mkMachString )
import CostCentreState
import Data.IORef import Data.IORef
import Control.Monad import Control.Monad
...@@ -182,6 +183,7 @@ mkDsEnvsFromTcGbl :: MonadIO m ...@@ -182,6 +183,7 @@ mkDsEnvsFromTcGbl :: MonadIO m
-> m (DsGblEnv, DsLclEnv) -> m (DsGblEnv, DsLclEnv)
mkDsEnvsFromTcGbl hsc_env msg_var tcg_env mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
= do { pm_iter_var <- liftIO $ newIORef 0 = do { pm_iter_var <- liftIO $ newIORef 0
; cc_st_var <- liftIO $ newIORef newCostCentreState
; let dflags = hsc_dflags hsc_env ; let dflags = hsc_dflags hsc_env
this_mod = tcg_mod tcg_env this_mod = tcg_mod tcg_env
type_env = tcg_type_env tcg_env type_env = tcg_type_env tcg_env
...@@ -190,7 +192,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env ...@@ -190,7 +192,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
complete_matches = hptCompleteSigs hsc_env complete_matches = hptCompleteSigs hsc_env
++ tcg_complete_matches tcg_env ++ tcg_complete_matches tcg_env
; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_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) runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
...@@ -210,6 +212,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside ...@@ -210,6 +212,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside
initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts hsc_env guts thing_inside initDsWithModGuts hsc_env guts thing_inside
= do { pm_iter_var <- newIORef 0 = do { pm_iter_var <- newIORef 0
; cc_st_var <- newIORef newCostCentreState
; msg_var <- newIORef emptyMessages ; msg_var <- newIORef emptyMessages
; let dflags = hsc_dflags hsc_env ; let dflags = hsc_dflags hsc_env
type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
...@@ -225,7 +228,7 @@ initDsWithModGuts hsc_env guts thing_inside ...@@ -225,7 +228,7 @@ initDsWithModGuts hsc_env guts thing_inside
envs = mkDsEnvs dflags this_mod rdr_env type_env envs = mkDsEnvs dflags this_mod rdr_env type_env
fam_inst_env msg_var pm_iter_var fam_inst_env msg_var pm_iter_var
complete_matches cc_st_var complete_matches
; runDs hsc_env envs thing_inside ; runDs hsc_env envs thing_inside
} }
...@@ -253,9 +256,9 @@ initTcDsForSolver thing_inside ...@@ -253,9 +256,9 @@ initTcDsForSolver thing_inside
thing_inside } thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef Int -> [CompleteMatch] -> IORef Messages -> IORef Int -> IORef CostCentreState
-> (DsGblEnv, DsLclEnv) -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
complete_matches complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
if_rec_types = Just (mod, return type_env) } 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 ...@@ -271,6 +274,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
, ds_dph_env = emptyGlobalRdrEnv , ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_complete_matches = completeMatchMap , ds_complete_matches = completeMatchMap
, ds_cc_st = cc_st_var
} }
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span , dsl_loc = real_span
......
...@@ -390,6 +390,7 @@ Library ...@@ -390,6 +390,7 @@ Library
TysPrim TysPrim
TysWiredIn TysWiredIn
CostCentre CostCentre
CostCentreState
ProfInit ProfInit
RnBinds RnBinds
RnEnv RnEnv
......
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
module CostCentre ( module CostCentre (
CostCentre(..), CcName, IsCafCC(..), CostCentre(..), CcName, CCFlavour(..),
-- All abstract except to friend: ParseIface.y -- All abstract except to friend: ParseIface.y
CostCentreStack, CostCentreStack,
...@@ -31,6 +31,7 @@ import Outputable ...@@ -31,6 +31,7 @@ import Outputable
import SrcLoc import SrcLoc
import FastString import FastString
import Util import Util
import CostCentreState
import Data.Data import Data.Data
...@@ -41,21 +42,18 @@ import Data.Data ...@@ -41,21 +42,18 @@ import Data.Data
data CostCentre data CostCentre
= NormalCC { = NormalCC {
cc_key :: {-# UNPACK #-} !Int, cc_flavour :: CCFlavour,
-- ^ Two cost centres may have the same name and -- ^ Two cost centres may have the same name and
-- module but different SrcSpans, so we need a way to -- module but different SrcSpans, so we need a way to
-- distinguish them easily and give them different -- distinguish them easily and give them different
-- object-code labels. So every CostCentre has a -- object-code labels. So every CostCentre has an
-- Unique that is distinct from every other -- associated flavour that indicates how it was
-- CostCentre in the same module. -- generated, and flavours that allow multiple instances
-- -- of the same name and module have a deterministic 0-based
-- XXX: should really be using Unique here, but we -- index.
-- need to derive Data below and there's no Data
-- instance for Unique.
cc_name :: CcName, -- ^ Name of the cost centre itself cc_name :: CcName, -- ^ Name of the cost centre itself
cc_mod :: Module, -- ^ Name of module defining this CC. cc_mod :: Module, -- ^ Name of module defining this CC.
cc_loc :: SrcSpan, cc_loc :: SrcSpan
cc_is_caf :: IsCafCC -- see below
} }
| AllCafsCC { | AllCafsCC {
...@@ -66,9 +64,22 @@ data CostCentre ...@@ -66,9 +64,22 @@ data CostCentre
type CcName = FastString type CcName = FastString
data IsCafCC = NotCafCC | CafCC -- | The flavour of a cost centre.
deriving (Eq, Ord, Data) --
-- 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 instance Eq CostCentre where
c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
...@@ -81,10 +92,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering ...@@ -81,10 +92,10 @@ cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
= m1 `compare` m2 = m1 `compare` m2
cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1}
NormalCC {cc_key = n2, cc_mod = m2} NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2}
-- first key is module name, then the integer key -- first key is module name, then centre name, then flavour
= (m1 `compare` m2) `thenCmp` (n1 `compare` n2) = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
cmpCostCentre other_1 other_2 cmpCostCentre other_1 other_2
= let = let
...@@ -102,9 +113,9 @@ cmpCostCentre other_1 other_2 ...@@ -102,9 +113,9 @@ cmpCostCentre other_1 other_2
-- Predicates on CostCentre -- Predicates on CostCentre
isCafCC :: CostCentre -> Bool isCafCC :: CostCentre -> Bool
isCafCC (AllCafsCC {}) = True isCafCC (AllCafsCC {}) = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True isCafCC (NormalCC {cc_flavour = CafCC}) = True
isCafCC _ = False isCafCC _ = False
-- | Is this a cost-centre which records scc counts -- | Is this a cost-centre which records scc counts
isSccCountCC :: CostCentre -> Bool isSccCountCC :: CostCentre -> Bool
...@@ -123,18 +134,17 @@ ccFromThisModule cc m = cc_mod cc == m ...@@ -123,18 +134,17 @@ ccFromThisModule cc m = cc_mod cc == m
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Building cost centres -- Building cost centres
mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC cc_name mod loc key mkUserCC cc_name mod loc flavour
= NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc, = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc,
cc_is_caf = NotCafCC {-might be changed-} cc_flavour = flavour
} }
mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre mkAutoCC :: Id -> Module -> CostCentre
mkAutoCC id mod is_caf mkAutoCC id mod
= NormalCC { cc_key = getKey (getUnique id), = NormalCC { cc_name = str, cc_mod = mod,
cc_name = str, cc_mod = mod,
cc_loc = nameSrcSpan (getName id), cc_loc = nameSrcSpan (getName id),
cc_is_caf = is_caf cc_flavour = CafCC
} }
where where
name = getName id name = getName id
...@@ -249,26 +259,44 @@ instance Outputable CostCentre where ...@@ -249,26 +259,44 @@ instance Outputable CostCentre where
pprCostCentreCore :: CostCentre -> SDoc pprCostCentreCore :: CostCentre -> SDoc
pprCostCentreCore (AllCafsCC {cc_mod = m}) pprCostCentreCore (AllCafsCC {cc_mod = m})
= text "__sccC" <+> braces (ppr m) = text "__sccC" <+> braces (ppr m)
pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc, pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
cc_is_caf = caf}) cc_mod = m, cc_loc = loc})
= text "__scc" <+> braces (hsep [ = text "__scc" <+> braces (hsep [
ppr m <> char '.' <> ftext n, ppr m <> char '.' <> ftext n,
whenPprDebug (ppr key), pprFlavourCore flavour,
pp_caf caf,
whenPprDebug (ppr loc) whenPprDebug (ppr loc)
]) ])
pp_caf :: IsCafCC -> SDoc -- ^ Print a flavour in Core
pp_caf CafCC = text "__C" pprFlavourCore :: CCFlavour -> SDoc
pp_caf _ = empty 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 -- Printing as a C label
ppCostCentreLbl :: CostCentre -> SDoc ppCostCentreLbl :: CostCentre -> SDoc
ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
cc_is_caf = is_caf})
= ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> = 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, -- This is the name to go in the user-displayed string,
-- recorded in the cost centre declaration -- recorded in the cost centre declaration
...@@ -277,7 +305,7 @@ costCentreUserName = unpackFS . costCentreUserNameFS ...@@ -277,7 +305,7 @@ costCentreUserName = unpackFS . costCentreUserNameFS
costCentreUserNameFS :: CostCentre -> FastString costCentreUserNameFS :: CostCentre -> FastString
costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" 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 = case is_caf of
CafCC -> mkFastString "CAF:" `appendFS` name CafCC -> mkFastString "CAF:" `appendFS` name
_ -> name _ -> name
...@@ -285,24 +313,32 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) ...@@ -285,24 +313,32 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan :: CostCentre -> SrcSpan
costCentreSrcSpan = cc_loc costCentreSrcSpan = cc_loc
instance Binary IsCafCC where instance Binary CCFlavour where
put_ bh CafCC = do put_ bh CafCC = do
putByte bh 0 putByte bh 0
put_ bh NotCafCC = do put_ bh (ExprCC i) = do
putByte bh 1 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 get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
0 -> do return CafCC 0 -> do return CafCC
_ -> do return NotCafCC 1 -> ExprCC <$> get bh
2 -> DeclCC <$> get bh
_ -> HpcCC <$> get bh
instance Binary CostCentre where instance Binary CostCentre where
put_ bh (NormalCC aa ab ac _ad ae) = do put_ bh (NormalCC aa ab ac _ad) = do
putByte bh 0 putByte bh 0
put_ bh aa put_ bh aa
put_ bh ab put_ bh ab
put_ bh ac put_ bh ac
put_ bh ae
put_ bh (AllCafsCC ae _af) = do put_ bh (AllCafsCC ae _af) = do
putByte bh 1 putByte bh 1
put_ bh ae put_ bh ae
...@@ -312,8 +348,7 @@ instance Binary CostCentre where ...@@ -312,8 +348,7 @@ instance Binary CostCentre where
0 -> do aa <- get bh 0 -> do aa <- get bh
ab <- get bh ab <- get bh
ac <- get bh ac <- get bh
ae <- get bh return (NormalCC aa ab ac noSrcSpan)
return (NormalCC aa ab ac noSrcSpan ae)
_ -> do ae <- get bh _ -> do ae <- get bh
return (AllCafsCC ae noSrcSpan) return (AllCafsCC ae noSrcSpan)
......
{-# 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)
...@@ -803,7 +803,7 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs ...@@ -803,7 +803,7 @@ mkTopStgRhs dflags this_mod ccs rhs_fvs bndr binder_info rhs
| otherwise = Updatable | otherwise = Updatable
-- CAF cost centres generated for -fcaf-all -- CAF cost centres generated for -fcaf-all
caf_cc = mkAutoCC bndr modl CafCC caf_cc = mkAutoCC bndr modl
caf_ccs = mkSingletonCCS caf_cc caf_ccs = mkSingletonCCS caf_cc
-- careful: the binder might be :Main.main, -- careful: the binder might be :Main.main,
-- which doesn't belong to module mod_name. -- which doesn't belong to module mod_name.
......
...@@ -22,7 +22,7 @@ import {-# SOURCE #-} TcExpr ( tcMonoExpr ) ...@@ -22,7 +22,7 @@ import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
, tcPatSynBuilderBind ) , tcPatSynBuilderBind )
import CoreSyn (Tickish (..)) import CoreSyn (Tickish (..))
import CostCentre (mkUserCC) import CostCentre (mkUserCC, CCFlavour(DeclCC))
import DynFlags import DynFlags
import FastString import FastString
import HsSyn import HsSyn
...@@ -62,7 +62,6 @@ import BasicTypes ...@@ -62,7 +62,6 @@ import BasicTypes
import Outputable import Outputable
import PrelNames( ipClassName ) import PrelNames( ipClassName )
import TcValidity (checkValidType) import TcValidity (checkValidType)
import Unique (getUnique)
import UniqFM import UniqFM
import UniqSet import UniqSet
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
...@@ -714,11 +713,12 @@ tcPolyCheck prag_fn ...@@ -714,11 +713,12 @@ tcPolyCheck prag_fn
; poly_id <- addInlinePrags poly_id prag_sigs ; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule ; mod <- getModule
; tick <- funBindTicks nm_loc mono_id mod prag_sigs
; let bind' = FunBind { fun_id = L nm_loc mono_id ; let bind' = FunBind { fun_id = L nm_loc mono_id
, fun_matches = matches' , fun_matches = matches'
, fun_co_fn = co_fn , fun_co_fn = co_fn
, bind_fvs = placeHolderNamesTc , bind_fvs = placeHolderNamesTc
, fun_tick = funBindTicks nm_loc mono_id mod prag_sigs } , fun_tick = tick }
export = ABE { abe_wrap = idHsWrapper export = ABE { abe_wrap = idHsWrapper
, abe_poly = poly_id , abe_poly = poly_id
...@@ -739,7 +739,7 @@ tcPolyCheck _prag_fn sig bind ...@@ -739,7 +739,7 @@ tcPolyCheck _prag_fn sig bind
= pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)