diff options
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 21 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 14 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
| -rw-r--r-- | compiler/profiling/CostCentre.hs | 131 | ||||
| -rw-r--r-- | compiler/profiling/CostCentreState.hs | 36 | ||||
| -rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.hs | 16 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 29 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 8 |
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! |