never executed always true always false
1 {-# LANGUAGE NamedFieldPuns #-}
2 {-# LANGUAGE TypeApplications #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveDataTypeable #-}
5 {-# LANGUAGE DeriveAnyClass #-}
6 {-# LANGUAGE DerivingStrategies #-}
7 {-# LANGUAGE TupleSections #-}
8
9 -- | Adds cost-centers to call sites selected with the @-fprof-caller=...@
10 -- flag.
11 module GHC.Core.Opt.CallerCC
12 ( addCallerCostCentres
13 , CallerCcFilter
14 , parseCallerCcFilter
15 ) where
16
17 import Data.Bifunctor
18 import Data.Word (Word8)
19 import Data.Maybe
20 import qualified Text.Parsec as P
21
22 import Control.Applicative
23 import GHC.Utils.Monad.State.Strict
24 import Data.Either
25 import Control.Monad
26
27 import GHC.Prelude
28 import GHC.Utils.Outputable as Outputable
29 import GHC.Driver.Session
30 import GHC.Driver.Ppr
31 import GHC.Types.CostCentre
32 import GHC.Types.CostCentre.State
33 import GHC.Types.Name hiding (varName)
34 import GHC.Types.Tickish
35 import GHC.Unit.Module.Name
36 import GHC.Unit.Module.ModGuts
37 import GHC.Types.SrcLoc
38 import GHC.Types.Var
39 import GHC.Unit.Types
40 import GHC.Data.FastString
41 import GHC.Core
42 import GHC.Core.Opt.Monad
43 import GHC.Utils.Panic
44 import qualified GHC.Utils.Binary as B
45
46 addCallerCostCentres :: ModGuts -> CoreM ModGuts
47 addCallerCostCentres guts = do
48 dflags <- getDynFlags
49 let filters = callerCcFilters dflags
50 let env :: Env
51 env = Env
52 { thisModule = mg_module guts
53 , ccState = newCostCentreState
54 , dflags = dflags
55 , revParents = []
56 , filters = filters
57 }
58 let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)
59 }
60 return guts'
61
62 doCoreProgram :: Env -> CoreProgram -> CoreProgram
63 doCoreProgram env binds = flip evalState newCostCentreState $ do
64 mapM (doBind env) binds
65
66 doBind :: Env -> CoreBind -> M CoreBind
67 doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs
68 doBind env (Rec bs) = Rec <$> mapM doPair bs
69 where
70 doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs
71
72 doExpr :: Env -> CoreExpr -> M CoreExpr
73 doExpr env e@(Var v)
74 | needsCallSiteCostCentre env v = do
75 let nameDoc :: SDoc
76 nameDoc = withUserStyle alwaysQualify DefaultDepth $
77 hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)
78
79 ccName :: CcName
80 ccName = mkFastString $ showSDoc (dflags env) nameDoc
81 ccIdx <- getCCIndex' ccName
82 let span = case revParents env of
83 top:_ -> nameSrcSpan $ varName top
84 _ -> noSrcSpan
85 cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span
86 tick :: CoreTickish
87 tick = ProfNote cc True True
88 pure $ Tick tick e
89 | otherwise = pure e
90 doExpr _env e@(Lit _) = pure e
91 doExpr env (f `App` x) = App <$> doExpr env f <*> doExpr env x
92 doExpr env (Lam b x) = Lam b <$> doExpr env x
93 doExpr env (Let b rhs) = Let <$> doBind env b <*> doExpr env rhs
94 doExpr env (Case scrut b ty alts) =
95 Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts
96 where
97 doAlt (Alt con bs rhs) = Alt con bs <$> doExpr env rhs
98 doExpr env (Cast expr co) = Cast <$> doExpr env expr <*> pure co
99 doExpr env (Tick t e) = Tick t <$> doExpr env e
100 doExpr _env e@(Type _) = pure e
101 doExpr _env e@(Coercion _) = pure e
102
103 type M = State CostCentreState
104
105 getCCIndex' :: FastString -> M CostCentreIndex
106 getCCIndex' name = state (getCCIndex name)
107
108 data Env = Env
109 { thisModule :: Module
110 , dflags :: DynFlags
111 , ccState :: CostCentreState
112 , revParents :: [Id]
113 , filters :: [CallerCcFilter]
114 }
115
116 addParent :: Id -> Env -> Env
117 addParent i env = env { revParents = i : revParents env }
118
119 parents :: Env -> [Id]
120 parents env = reverse (revParents env)
121
122 needsCallSiteCostCentre :: Env -> Id -> Bool
123 needsCallSiteCostCentre env i =
124 any matches (filters env)
125 where
126 matches :: CallerCcFilter -> Bool
127 matches ccf =
128 checkModule && checkFunc
129 where
130 checkModule =
131 case ccfModuleName ccf of
132 Just modFilt
133 | Just iMod <- nameModule_maybe (varName i)
134 -> moduleName iMod == modFilt
135 | otherwise -> False
136 Nothing -> True
137 checkFunc =
138 occNameMatches (ccfFuncName ccf) (getOccName i)
139
140 data NamePattern
141 = PChar Char NamePattern
142 | PWildcard NamePattern
143 | PEnd
144
145 instance Outputable NamePattern where
146 ppr (PChar c rest) = char c <> ppr rest
147 ppr (PWildcard rest) = char '*' <> ppr rest
148 ppr PEnd = Outputable.empty
149
150 instance B.Binary NamePattern where
151 get bh = do
152 tag <- B.get bh
153 case tag :: Word8 of
154 0 -> PChar <$> B.get bh <*> B.get bh
155 1 -> PWildcard <$> B.get bh
156 2 -> pure PEnd
157 _ -> panic "Binary(NamePattern): Invalid tag"
158 put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y
159 put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x
160 put_ bh PEnd = B.put_ bh (2 :: Word8)
161
162 occNameMatches :: NamePattern -> OccName -> Bool
163 occNameMatches pat = go pat . occNameString
164 where
165 go :: NamePattern -> String -> Bool
166 go PEnd "" = True
167 go (PChar c rest) (d:s)
168 = d == c && go rest s
169 go (PWildcard rest) s
170 = go rest s || go (PWildcard rest) (tail s)
171 go _ _ = False
172
173 type Parser = P.Parsec String ()
174
175 parseNamePattern :: Parser NamePattern
176 parseNamePattern = pattern
177 where
178 pattern = star <|> wildcard <|> char <|> end
179 star = PChar '*' <$ P.string "\\*" <*> pattern
180 wildcard = do
181 void $ P.char '*'
182 PWildcard <$> pattern
183 char = PChar <$> P.anyChar <*> pattern
184 end = PEnd <$ P.eof
185
186 data CallerCcFilter
187 = CallerCcFilter { ccfModuleName :: Maybe ModuleName
188 , ccfFuncName :: NamePattern
189 }
190
191 instance Outputable CallerCcFilter where
192 ppr ccf =
193 maybe (char '*') ppr (ccfModuleName ccf)
194 <> char '.'
195 <> ppr (ccfFuncName ccf)
196
197 instance B.Binary CallerCcFilter where
198 get bh = CallerCcFilter <$> B.get bh <*> B.get bh
199 put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y
200
201 parseCallerCcFilter :: String -> Either String CallerCcFilter
202 parseCallerCcFilter =
203 first show . P.parse parseCallerCcFilter' "caller-CC filter"
204
205 parseCallerCcFilter' :: Parser CallerCcFilter
206 parseCallerCcFilter' =
207 CallerCcFilter
208 <$> moduleFilter
209 <* P.char '.'
210 <*> parseNamePattern
211 where
212 moduleFilter :: Parser (Maybe ModuleName)
213 moduleFilter =
214 (Just . mkModuleName <$> moduleName)
215 <|>
216 (Nothing <$ P.char '*')
217
218 moduleName :: Parser String
219 moduleName = do
220 c <- P.upper
221 cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_"
222 rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName
223 return $ c : (cs ++ fromMaybe "" rest)
224