never executed always true always false
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE NondecreasingIndentation #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
6
7 {-
8 (c) Galois, 2006
9 (c) University of Glasgow, 2007
10 -}
11
12 module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where
13
14 import GHC.Prelude as Prelude
15
16 import GHC.Driver.Session
17 import GHC.Driver.Backend
18 import GHC.Driver.Ppr
19 import GHC.Driver.Env
20
21 import qualified GHC.Runtime.Interpreter as GHCi
22 import GHCi.RemoteTypes
23 import GHC.ByteCode.Types
24 import GHC.Stack.CCS
25 import GHC.Hs
26 import GHC.Unit
27 import GHC.Cmm.CLabel
28
29 import GHC.Core.Type
30 import GHC.Core.TyCon
31
32 import GHC.Data.Maybe
33 import GHC.Data.FastString
34 import GHC.Data.Bag
35
36 import GHC.Utils.Misc
37 import GHC.Utils.Outputable as Outputable
38 import GHC.Utils.Panic
39 import GHC.Utils.Monad
40 import GHC.Utils.Logger
41
42 import GHC.Types.SrcLoc
43 import GHC.Types.Basic
44 import GHC.Types.Id
45 import GHC.Types.Var.Set
46 import GHC.Types.Name.Set hiding (FreeVars)
47 import GHC.Types.Name
48 import GHC.Types.HpcInfo
49 import GHC.Types.CostCentre
50 import GHC.Types.CostCentre.State
51 import GHC.Types.ForeignStubs
52 import GHC.Types.Tickish
53
54 import Control.Monad
55 import Data.List (isSuffixOf, intersperse)
56 import Data.Array
57 import Data.Time
58 import System.Directory
59
60 import Trace.Hpc.Mix
61 import Trace.Hpc.Util
62
63 import qualified Data.ByteString as BS
64 import Data.Set (Set)
65 import qualified Data.Set as Set
66
67 {-
68 ************************************************************************
69 * *
70 * The main function: addTicksToBinds
71 * *
72 ************************************************************************
73 -}
74
75 addTicksToBinds
76 :: HscEnv
77 -> Module
78 -> ModLocation -- ... off the current module
79 -> NameSet -- Exported Ids. When we call addTicksToBinds,
80 -- isExportedId doesn't work yet (the desugarer
81 -- hasn't set it), so we have to work from this set.
82 -> [TyCon] -- Type constructor in this module
83 -> LHsBinds GhcTc
84 -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
85
86 addTicksToBinds hsc_env mod mod_loc exports tyCons binds
87 | let dflags = hsc_dflags hsc_env
88 passes = coveragePasses dflags
89 , not (null passes)
90 , Just orig_file <- ml_hs_file mod_loc = do
91
92 let orig_file2 = guessSourceFile binds orig_file
93
94 tickPass tickish (binds,st) =
95 let env = TTE
96 { fileName = mkFastString orig_file2
97 , declPath = []
98 , tte_dflags = dflags
99 , exports = exports
100 , inlines = emptyVarSet
101 , inScope = emptyVarSet
102 , blackList = Set.fromList $
103 mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of
104 RealSrcSpan l _ -> Just l
105 UnhelpfulSpan _ -> Nothing)
106 tyCons
107 , density = mkDensity tickish dflags
108 , this_mod = mod
109 , tickishType = tickish
110 }
111 (binds',_,st') = unTM (addTickLHsBinds binds) env st
112 in (binds', st')
113
114 initState = TT { tickBoxCount = 0
115 , mixEntries = []
116 , ccIndices = newCostCentreState
117 }
118
119 (binds1,st) = foldr tickPass (binds, initState) passes
120
121 let tickCount = tickBoxCount st
122 entries = reverse $ mixEntries st
123 hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
124 modBreaks <- mkModBreaks hsc_env mod tickCount entries
125
126 let logger = hsc_logger hsc_env
127 putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell
128 (pprLHsBinds binds1)
129
130 return (binds1, HpcInfo tickCount hashNo, modBreaks)
131
132 | otherwise = return (binds, emptyHpcInfo False, Nothing)
133
134 guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
135 guessSourceFile binds orig_file =
136 -- Try look for a file generated from a .hsc file to a
137 -- .hs file, by peeking ahead.
138 let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
139 srcSpanFileName_maybe (locA pos) : rest) [] binds
140 in
141 case top_pos of
142 (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
143 -> unpackFS file_name
144 _ -> orig_file
145
146
147 mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)
148 mkModBreaks hsc_env mod count entries
149 | Just interp <- hsc_interp hsc_env
150 , breakpointsEnabled (hsc_dflags hsc_env) = do
151 breakArray <- GHCi.newBreakArray interp (length entries)
152 ccs <- mkCCSArray hsc_env mod count entries
153 let
154 locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]
155 varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]
156 declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
157 return $ Just $ emptyModBreaks
158 { modBreaks_flags = breakArray
159 , modBreaks_locs = locsTicks
160 , modBreaks_vars = varsTicks
161 , modBreaks_decls = declsTicks
162 , modBreaks_ccs = ccs
163 }
164 | otherwise = return Nothing
165
166 mkCCSArray
167 :: HscEnv -> Module -> Int -> [MixEntry_]
168 -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
169 mkCCSArray hsc_env modul count entries =
170 case hsc_interp hsc_env of
171 Just interp | GHCi.interpreterProfiled interp -> do
172 let module_str = moduleNameString (moduleName modul)
173 costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
174 return (listArray (0,count-1) costcentres)
175
176 _ -> return (listArray (0,-1) [])
177 where
178 dflags = hsc_dflags hsc_env
179 mk_one (srcspan, decl_path, _, _) = (name, src)
180 where name = concat (intersperse "." decl_path)
181 src = showSDoc dflags (ppr srcspan)
182
183
184 writeMixEntries
185 :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
186 writeMixEntries dflags mod count entries filename
187 | not (gopt Opt_Hpc dflags) = return 0
188 | otherwise = do
189 let
190 hpc_dir = hpcDir dflags
191 mod_name = moduleNameString (moduleName mod)
192
193 hpc_mod_dir
194 | moduleUnit mod == mainUnit = hpc_dir
195 | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)
196
197 tabStop = 8 -- <tab> counts as a normal char in GHC's
198 -- location ranges.
199
200 createDirectoryIfMissing True hpc_mod_dir
201 modTime <- getModificationUTCTime filename
202 let entries' = [ (hpcPos, box)
203 | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
204 when (entries' `lengthIsNot` count) $
205 panic "the number of .mix entries are inconsistent"
206 let hashNo = mixHash filename modTime tabStop entries'
207 mixCreate hpc_mod_dir mod_name
208 $ Mix filename modTime (toHash hashNo) tabStop entries'
209 return hashNo
210
211
212 -- -----------------------------------------------------------------------------
213 -- TickDensity: where to insert ticks
214
215 data TickDensity
216 = TickForCoverage -- for Hpc
217 | TickForBreakPoints -- for GHCi
218 | TickAllFunctions -- for -prof-auto-all
219 | TickTopFunctions -- for -prof-auto-top
220 | TickExportedFunctions -- for -prof-auto-exported
221 | TickCallSites -- for stack tracing
222 deriving Eq
223
224 mkDensity :: TickishType -> DynFlags -> TickDensity
225 mkDensity tickish dflags = case tickish of
226 HpcTicks -> TickForCoverage
227 SourceNotes -> TickForCoverage
228 Breakpoints -> TickForBreakPoints
229 ProfNotes ->
230 case profAuto dflags of
231 ProfAutoAll -> TickAllFunctions
232 ProfAutoTop -> TickTopFunctions
233 ProfAutoExports -> TickExportedFunctions
234 ProfAutoCalls -> TickCallSites
235 _other -> panic "mkDensity"
236
237 -- | Decide whether to add a tick to a binding or not.
238 shouldTickBind :: TickDensity
239 -> Bool -- top level?
240 -> Bool -- exported?
241 -> Bool -- simple pat bind?
242 -> Bool -- INLINE pragma?
243 -> Bool
244
245 shouldTickBind density top_lev exported _simple_pat inline
246 = case density of
247 TickForBreakPoints -> False
248 -- we never add breakpoints to simple pattern bindings
249 -- (there's always a tick on the rhs anyway).
250 TickAllFunctions -> not inline
251 TickTopFunctions -> top_lev && not inline
252 TickExportedFunctions -> exported && not inline
253 TickForCoverage -> True
254 TickCallSites -> False
255
256 shouldTickPatBind :: TickDensity -> Bool -> Bool
257 shouldTickPatBind density top_lev
258 = case density of
259 TickForBreakPoints -> False
260 TickAllFunctions -> True
261 TickTopFunctions -> top_lev
262 TickExportedFunctions -> False
263 TickForCoverage -> False
264 TickCallSites -> False
265
266 -- -----------------------------------------------------------------------------
267 -- Adding ticks to bindings
268
269 addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
270 addTickLHsBinds = mapBagM addTickLHsBind
271
272 addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
273 addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
274 abs_exports = abs_exports })) =
275 withEnv add_exports $
276 withEnv add_inlines $ do
277 binds' <- addTickLHsBinds binds
278 return $ L pos $ bind { abs_binds = binds' }
279 where
280 -- in AbsBinds, the Id on each binding is not the actual top-level
281 -- Id that we are defining, they are related by the abs_exports
282 -- field of AbsBinds. So if we're doing TickExportedFunctions we need
283 -- to add the local Ids to the set of exported Names so that we know to
284 -- tick the right bindings.
285 add_exports env =
286 env{ exports = exports env `extendNameSetList`
287 [ idName mid
288 | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
289 , idName pid `elemNameSet` (exports env) ] }
290
291 -- See Note [inline sccs]
292 add_inlines env =
293 env{ inlines = inlines env `extendVarSetList`
294 [ mid
295 | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
296 , isInlinePragma (idInlinePragma pid) ] }
297
298 addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
299 let name = getOccString id
300 decl_path <- getPathEntry
301 density <- getDensity
302
303 inline_ids <- liftM inlines getEnv
304 -- See Note [inline sccs]
305 let inline = isInlinePragma (idInlinePragma id)
306 || id `elemVarSet` inline_ids
307
308 -- See Note [inline sccs]
309 tickish <- tickishType `liftM` getEnv
310 if inline && tickish == ProfNotes then return (L pos funBind) else do
311
312 (fvs, mg) <-
313 getFreeVars $
314 addPathEntry name $
315 addTickMatchGroup False (fun_matches funBind)
316
317 blackListed <- isBlackListed (locA pos)
318 exported_names <- liftM exports getEnv
319
320 -- We don't want to generate code for blacklisted positions
321 -- We don't want redundant ticks on simple pattern bindings
322 -- We don't want to tick non-exported bindings in TickExportedFunctions
323 let simple = isSimplePatBind funBind
324 toplev = null decl_path
325 exported = idName id `elemNameSet` exported_names
326
327 tick <- if not blackListed &&
328 shouldTickBind density toplev exported simple inline
329 then
330 bindTick density name (locA pos) fvs
331 else
332 return Nothing
333
334 let mbCons = maybe Prelude.id (:)
335 return $ L pos $ funBind { fun_matches = mg
336 , fun_tick = tick `mbCons` fun_tick funBind }
337
338 where
339 -- a binding is a simple pattern binding if it is a funbind with
340 -- zero patterns
341 isSimplePatBind :: HsBind GhcTc -> Bool
342 isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
343
344 -- TODO: Revisit this
345 addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
346 , pat_rhs = rhs }))) = do
347
348 let simplePatId = isSimplePat lhs
349
350 -- TODO: better name for rhs's for non-simple patterns?
351 let name = maybe "(...)" getOccString simplePatId
352
353 (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
354 let pat' = pat { pat_rhs = rhs'}
355
356 -- Should create ticks here?
357 density <- getDensity
358 decl_path <- getPathEntry
359 let top_lev = null decl_path
360 if not (shouldTickPatBind density top_lev)
361 then return (L pos pat')
362 else do
363
364 let mbCons = maybe id (:)
365
366 let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
367
368 -- Allocate the ticks
369
370 rhs_tick <- bindTick density name (locA pos) fvs
371 let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
372
373 patvar_tickss <- case simplePatId of
374 Just{} -> return initial_patvar_tickss
375 Nothing -> do
376 let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)
377 patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars
378 return
379 (zipWith mbCons patvar_ticks
380 (initial_patvar_tickss ++ repeat []))
381
382 return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
383
384 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
385 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
386 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
387
388 bindTick
389 :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
390 bindTick density name pos fvs = do
391 decl_path <- getPathEntry
392 let
393 toplev = null decl_path
394 count_entries = toplev || density == TickAllFunctions
395 top_only = density /= TickAllFunctions
396 box_label = if toplev then TopLevelBox [name]
397 else LocalBox (decl_path ++ [name])
398 --
399 allocATickBox box_label count_entries top_only pos fvs
400
401
402 -- Note [inline sccs]
403 --
404 -- The reason not to add ticks to INLINE functions is that this is
405 -- sometimes handy for avoiding adding a tick to a particular function
406 -- (see #6131)
407 --
408 -- So for now we do not add any ticks to INLINE functions at all.
409 --
410 -- We used to use isAnyInlinePragma to figure out whether to avoid adding
411 -- ticks for this purpose. However, #12962 indicates that this contradicts
412 -- the documentation on profiling (which only mentions INLINE pragmas).
413 -- So now we're more careful about what we avoid adding ticks to.
414
415 -- -----------------------------------------------------------------------------
416 -- Decorate an LHsExpr with ticks
417
418 -- selectively add ticks to interesting expressions
419 addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
420 addTickLHsExpr e@(L pos e0) = do
421 d <- getDensity
422 case d of
423 TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
424 TickForCoverage -> tick_it
425 TickCallSites | isCallSite e0 -> tick_it
426 _other -> dont_tick_it
427 where
428 tick_it = allocTickBox (ExpBox False) False False (locA pos)
429 $ addTickHsExpr e0
430 dont_tick_it = addTickLHsExprNever e
431
432 -- Add a tick to an expression which is the RHS of an equation or a binding.
433 -- We always consider these to be breakpoints, unless the expression is a 'let'
434 -- (because the body will definitely have a tick somewhere). ToDo: perhaps
435 -- we should treat 'case' and 'if' the same way?
436 addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
437 addTickLHsExprRHS e@(L pos e0) = do
438 d <- getDensity
439 case d of
440 TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
441 | otherwise -> tick_it
442 TickForCoverage -> tick_it
443 TickCallSites | isCallSite e0 -> tick_it
444 _other -> dont_tick_it
445 where
446 tick_it = allocTickBox (ExpBox False) False False (locA pos)
447 $ addTickHsExpr e0
448 dont_tick_it = addTickLHsExprNever e
449
450 -- The inner expression of an evaluation context:
451 -- let binds in [], ( [] )
452 -- we never tick these if we're doing HPC, but otherwise
453 -- we treat it like an ordinary expression.
454 addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
455 addTickLHsExprEvalInner e = do
456 d <- getDensity
457 case d of
458 TickForCoverage -> addTickLHsExprNever e
459 _otherwise -> addTickLHsExpr e
460
461 -- | A let body is treated differently from addTickLHsExprEvalInner
462 -- above with TickForBreakPoints, because for breakpoints we always
463 -- want to tick the body, even if it is not a redex. See test
464 -- break012. This gives the user the opportunity to inspect the
465 -- values of the let-bound variables.
466 addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
467 addTickLHsExprLetBody e@(L pos e0) = do
468 d <- getDensity
469 case d of
470 TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
471 | otherwise -> tick_it
472 _other -> addTickLHsExprEvalInner e
473 where
474 tick_it = allocTickBox (ExpBox False) False False (locA pos)
475 $ addTickHsExpr e0
476 dont_tick_it = addTickLHsExprNever e
477
478 -- version of addTick that does not actually add a tick,
479 -- because the scope of this tick is completely subsumed by
480 -- another.
481 addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
482 addTickLHsExprNever (L pos e0) = do
483 e1 <- addTickHsExpr e0
484 return $ L pos e1
485
486 -- General heuristic: expressions which are calls (do not denote
487 -- values) are good break points.
488 isGoodBreakExpr :: HsExpr GhcTc -> Bool
489 isGoodBreakExpr e = isCallSite e
490
491 isCallSite :: HsExpr GhcTc -> Bool
492 isCallSite HsApp{} = True
493 isCallSite HsAppType{} = True
494 isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))
495 = isCallSite e
496 -- NB: OpApp, SectionL, SectionR are all expanded out
497 isCallSite _ = False
498
499 addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
500 addTickLHsExprOptAlt oneOfMany (L pos e0)
501 = ifDensity TickForCoverage
502 (allocTickBox (ExpBox oneOfMany) False False (locA pos)
503 $ addTickHsExpr e0)
504 (addTickLHsExpr (L pos e0))
505
506 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
507 addBinTickLHsExpr boxLabel (L pos e0)
508 = ifDensity TickForCoverage
509 (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)
510 (addTickLHsExpr (L pos e0))
511
512
513 -- -----------------------------------------------------------------------------
514 -- Decorate the body of an HsExpr with ticks.
515 -- (Whether to put a tick around the whole expression was already decided,
516 -- in the addTickLHsExpr family of functions.)
517
518 addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
519 addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
520 addTickHsExpr e@(HsUnboundVar {}) = return e
521 addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e
522
523 addTickHsExpr e@(HsIPVar {}) = return e
524 addTickHsExpr e@(HsOverLit {}) = return e
525 addTickHsExpr e@(HsOverLabel{}) = return e
526 addTickHsExpr e@(HsLit {}) = return e
527 addTickHsExpr (HsLam x mg) = liftM (HsLam x)
528 (addTickMatchGroup True mg)
529 addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
530 (addTickMatchGroup True mgs)
531 addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
532 (addTickLHsExpr e2)
533 addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
534 (addTickLHsExprNever e)
535 (return ty)
536 addTickHsExpr (OpApp fix e1 e2 e3) =
537 liftM4 OpApp
538 (return fix)
539 (addTickLHsExpr e1)
540 (addTickLHsExprNever e2)
541 (addTickLHsExpr e3)
542 addTickHsExpr (NegApp x e neg) =
543 liftM2 (NegApp x)
544 (addTickLHsExpr e)
545 (addTickSyntaxExpr hpcSrcSpan neg)
546 addTickHsExpr (HsPar x lpar e rpar) = do
547 e' <- addTickLHsExprEvalInner e
548 return (HsPar x lpar e' rpar)
549 addTickHsExpr (SectionL x e1 e2) =
550 liftM2 (SectionL x)
551 (addTickLHsExpr e1)
552 (addTickLHsExprNever e2)
553 addTickHsExpr (SectionR x e1 e2) =
554 liftM2 (SectionR x)
555 (addTickLHsExprNever e1)
556 (addTickLHsExpr e2)
557 addTickHsExpr (ExplicitTuple x es boxity) =
558 liftM2 (ExplicitTuple x)
559 (mapM addTickTupArg es)
560 (return boxity)
561 addTickHsExpr (ExplicitSum ty tag arity e) = do
562 e' <- addTickLHsExpr e
563 return (ExplicitSum ty tag arity e')
564 addTickHsExpr (HsCase x e mgs) =
565 liftM2 (HsCase x)
566 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
567 -- be evaluated.
568 (addTickMatchGroup False mgs)
569 addTickHsExpr (HsIf x e1 e2 e3) =
570 liftM3 (HsIf x)
571 (addBinTickLHsExpr (BinBox CondBinBox) e1)
572 (addTickLHsExprOptAlt True e2)
573 (addTickLHsExprOptAlt True e3)
574 addTickHsExpr (HsMultiIf ty alts)
575 = do { let isOneOfMany = case alts of [_] -> False; _ -> True
576 ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
577 ; return $ HsMultiIf ty alts' }
578 addTickHsExpr (HsLet x tkLet binds tkIn e) =
579 bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
580 binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
581 e' <- addTickLHsExprLetBody e
582 return (HsLet x tkLet binds' tkIn e')
583 addTickHsExpr (HsDo srcloc cxt (L l stmts))
584 = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
585 ; return (HsDo srcloc cxt (L l stmts')) }
586 where
587 forQual = case cxt of
588 ListComp -> Just $ BinBox QualBinBox
589 _ -> Nothing
590 addTickHsExpr (ExplicitList ty es)
591 = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)
592
593 addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
594
595 addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
596 = do { rec_binds' <- addTickHsRecordBinds rec_binds
597 ; return (expr { rcon_flds = rec_binds' }) }
598
599 addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds })
600 = do { e' <- addTickLHsExpr e
601 ; flds' <- mapM addTickHsRecField flds
602 ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }
603 addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })
604 = do { e' <- addTickLHsExpr e
605 ; flds' <- mapM addTickHsRecField flds
606 ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) }
607
608 addTickHsExpr (ExprWithTySig x e ty) =
609 liftM3 ExprWithTySig
610 (return x)
611 (addTickLHsExprNever e) -- No need to tick the inner expression
612 -- for expressions with signatures
613 (return ty)
614 addTickHsExpr (ArithSeq ty wit arith_seq) =
615 liftM3 ArithSeq
616 (return ty)
617 (addTickWit wit)
618 (addTickArithSeqInfo arith_seq)
619 where addTickWit Nothing = return Nothing
620 addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
621 return (Just fl')
622
623 addTickHsExpr (HsPragE x p e) =
624 liftM (HsPragE x p) (addTickLHsExpr e)
625 addTickHsExpr e@(HsBracket {}) = return e
626 addTickHsExpr e@(HsTcBracketOut {}) = return e
627 addTickHsExpr e@(HsRnBracketOut {}) = return e
628 addTickHsExpr e@(HsSpliceE {}) = return e
629 addTickHsExpr e@(HsGetField {}) = return e
630 addTickHsExpr e@(HsProjection {}) = return e
631 addTickHsExpr (HsProc x pat cmdtop) =
632 liftM2 (HsProc x)
633 (addTickLPat pat)
634 (liftL (addTickHsCmdTop) cmdtop)
635 addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
636 liftM (XExpr . WrapExpr . HsWrap w) $
637 (addTickHsExpr e) -- Explicitly no tick on inside
638 addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
639 liftM (XExpr . ExpansionExpr . HsExpanded a) $
640 (addTickHsExpr b)
641
642 addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
643 -- We used to do a freeVar on a pat-syn builder, but actually
644 -- such builders are never in the inScope env, which
645 -- doesn't include top level bindings
646
647 -- We might encounter existing ticks (multiple Coverage passes)
648 addTickHsExpr (XExpr (HsTick t e)) =
649 liftM (XExpr . HsTick t) (addTickLHsExprNever e)
650 addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
651 liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
652
653 addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
654 addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
655 ; return (Present x e') }
656 addTickTupArg (Missing ty) = return (Missing ty)
657
658
659 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
660 -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
661 addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
662 let isOneOfMany = matchesOneOfMany matches
663 matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
664 return $ mg { mg_alts = L l matches' }
665
666 addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
667 -> TM (Match GhcTc (LHsExpr GhcTc))
668 addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
669 , m_grhss = gRHSs }) =
670 bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
671 gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
672 return $ match { m_grhss = gRHSs' }
673
674 addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
675 -> TM (GRHSs GhcTc (LHsExpr GhcTc))
676 addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =
677 bindLocals binders $ do
678 local_binds' <- addTickHsLocalBinds local_binds
679 guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
680 return $ GRHSs x guarded' local_binds'
681 where
682 binders = collectLocalBinders CollNoDictBinders local_binds
683
684 addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
685 -> TM (GRHS GhcTc (LHsExpr GhcTc))
686 addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
687 (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
688 (addTickGRHSBody isOneOfMany isLambda expr)
689 return $ GRHS x stmts' expr'
690
691 addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
692 addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
693 d <- getDensity
694 case d of
695 TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
696 TickAllFunctions | isLambda ->
697 addPathEntry "\\" $
698 allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $
699 addTickHsExpr e0
700 _otherwise ->
701 addTickLHsExprRHS expr
702
703 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
704 -> TM [ExprLStmt GhcTc]
705 addTickLStmts isGuard stmts = do
706 (stmts, _) <- addTickLStmts' isGuard stmts (return ())
707 return stmts
708
709 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
710 -> TM ([ExprLStmt GhcTc], a)
711 addTickLStmts' isGuard lstmts res
712 = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $
713 do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
714 ; a <- res
715 ; return (lstmts', a) }
716
717 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
718 -> TM (Stmt GhcTc (LHsExpr GhcTc))
719 addTickStmt _isGuard (LastStmt x e noret ret) =
720 liftM3 (LastStmt x)
721 (addTickLHsExpr e)
722 (pure noret)
723 (addTickSyntaxExpr hpcSrcSpan ret)
724 addTickStmt _isGuard (BindStmt xbs pat e) =
725 liftM4 (\b f -> BindStmt $ XBindStmtTc
726 { xbstc_bindOp = b
727 , xbstc_boundResultType = xbstc_boundResultType xbs
728 , xbstc_boundResultMult = xbstc_boundResultMult xbs
729 , xbstc_failOp = f
730 })
731 (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))
732 (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))
733 (addTickLPat pat)
734 (addTickLHsExprRHS e)
735 addTickStmt isGuard (BodyStmt x e bind' guard') =
736 liftM3 (BodyStmt x)
737 (addTick isGuard e)
738 (addTickSyntaxExpr hpcSrcSpan bind')
739 (addTickSyntaxExpr hpcSrcSpan guard')
740 addTickStmt _isGuard (LetStmt x binds) =
741 liftM (LetStmt x)
742 (addTickHsLocalBinds binds)
743 addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =
744 liftM3 (ParStmt x)
745 (mapM (addTickStmtAndBinders isGuard) pairs)
746 (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))
747 (addTickSyntaxExpr hpcSrcSpan bindExpr)
748 addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
749 args' <- mapM (addTickApplicativeArg isGuard) args
750 return (ApplicativeStmt body_ty args' mb_join)
751
752 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
753 , trS_by = by, trS_using = using
754 , trS_ret = returnExpr, trS_bind = bindExpr
755 , trS_fmap = liftMExpr }) = do
756 t_s <- addTickLStmts isGuard stmts
757 t_y <- fmapMaybeM addTickLHsExprRHS by
758 t_u <- addTickLHsExprRHS using
759 t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
760 t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
761 t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))
762 return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
763 , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
764
765 addTickStmt isGuard stmt@(RecStmt {})
766 = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)
767 ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
768 ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
769 ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
770 ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
771 , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
772
773 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
774 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
775 | otherwise = addTickLHsExprRHS e
776
777 addTickApplicativeArg
778 :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
779 -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
780 addTickApplicativeArg isGuard (op, arg) =
781 liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
782 where
783 addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
784 ApplicativeArgOne
785 <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
786 <*> addTickLPat pat
787 <*> addTickLHsExpr expr
788 <*> pure isBody
789 addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
790 (ApplicativeArgMany x)
791 <$> addTickLStmts isGuard stmts
792 <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
793 <*> addTickLPat pat
794 <*> pure ctxt
795
796 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
797 -> TM (ParStmtBlock GhcTc GhcTc)
798 addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
799 liftM3 (ParStmtBlock x)
800 (addTickLStmts isGuard stmts)
801 (return ids)
802 (addTickSyntaxExpr hpcSrcSpan returnExpr)
803
804 addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
805 addTickHsLocalBinds (HsValBinds x binds) =
806 liftM (HsValBinds x)
807 (addTickHsValBinds binds)
808 addTickHsLocalBinds (HsIPBinds x binds) =
809 liftM (HsIPBinds x)
810 (addTickHsIPBinds binds)
811 addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
812
813 addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
814 -> TM (HsValBindsLR GhcTc (GhcPass b))
815 addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
816 b <- liftM2 NValBinds
817 (mapM (\ (rec,binds') ->
818 liftM2 (,)
819 (return rec)
820 (addTickLHsBinds binds'))
821 binds)
822 (return sigs)
823 return $ XValBindsLR b
824 addTickHsValBinds _ = panic "addTickHsValBinds"
825
826 addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
827 addTickHsIPBinds (IPBinds dictbinds ipbinds) =
828 liftM2 IPBinds
829 (return dictbinds)
830 (mapM (liftL (addTickIPBind)) ipbinds)
831
832 addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
833 addTickIPBind (IPBind x nm e) =
834 liftM2 (IPBind x)
835 (return nm)
836 (addTickLHsExpr e)
837
838 -- There is no location here, so we might need to use a context location??
839 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
840 addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
841 x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))
842 return $ syn { syn_expr = x' }
843 addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
844
845 -- we do not walk into patterns.
846 addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
847 addTickLPat pat = return pat
848
849 addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
850 addTickHsCmdTop (HsCmdTop x cmd) =
851 liftM2 HsCmdTop
852 (return x)
853 (addTickLHsCmd cmd)
854
855 addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
856 addTickLHsCmd (L pos c0) = do
857 c1 <- addTickHsCmd c0
858 return $ L pos c1
859
860 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
861 addTickHsCmd (HsCmdLam x matchgroup) =
862 liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
863 addTickHsCmd (HsCmdApp x c e) =
864 liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
865 {-
866 addTickHsCmd (OpApp e1 c2 fix c3) =
867 liftM4 OpApp
868 (addTickLHsExpr e1)
869 (addTickLHsCmd c2)
870 (return fix)
871 (addTickLHsCmd c3)
872 -}
873 addTickHsCmd (HsCmdPar x lpar e rpar) = do
874 e' <- addTickLHsCmd e
875 return (HsCmdPar x lpar e' rpar)
876 addTickHsCmd (HsCmdCase x e mgs) =
877 liftM2 (HsCmdCase x)
878 (addTickLHsExpr e)
879 (addTickCmdMatchGroup mgs)
880 addTickHsCmd (HsCmdLamCase x mgs) =
881 liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs)
882 addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
883 liftM3 (HsCmdIf x cnd)
884 (addBinTickLHsExpr (BinBox CondBinBox) e1)
885 (addTickLHsCmd c2)
886 (addTickLHsCmd c3)
887 addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =
888 bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
889 binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
890 c' <- addTickLHsCmd c
891 return (HsCmdLet x tkLet binds' tkIn c')
892 addTickHsCmd (HsCmdDo srcloc (L l stmts))
893 = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
894 ; return (HsCmdDo srcloc (L l stmts')) }
895
896 addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) =
897 liftM5 HsCmdArrApp
898 (return arr_ty)
899 (addTickLHsExpr e1)
900 (addTickLHsExpr e2)
901 (return ty1)
902 (return lr)
903 addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
904 liftM4 (HsCmdArrForm x)
905 (addTickLHsExpr e)
906 (return f)
907 (return fix)
908 (mapM (liftL (addTickHsCmdTop)) cmdtop)
909
910 addTickHsCmd (XCmd (HsWrap w cmd)) =
911 liftM XCmd $
912 liftM (HsWrap w) (addTickHsCmd cmd)
913
914 -- Others should never happen in a command context.
915 --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
916
917 addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
918 -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
919 addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
920 matches' <- mapM (liftL addTickCmdMatch) matches
921 return $ mg { mg_alts = L l matches' }
922
923 addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
924 addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
925 bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
926 gRHSs' <- addTickCmdGRHSs gRHSs
927 return $ match { m_grhss = gRHSs' }
928
929 addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
930 addTickCmdGRHSs (GRHSs x guarded local_binds) =
931 bindLocals binders $ do
932 local_binds' <- addTickHsLocalBinds local_binds
933 guarded' <- mapM (liftL addTickCmdGRHS) guarded
934 return $ GRHSs x guarded' local_binds'
935 where
936 binders = collectLocalBinders CollNoDictBinders local_binds
937
938 addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
939 -- The *guards* are *not* Cmds, although the body is
940 -- C.f. addTickGRHS for the BinBox stuff
941 addTickCmdGRHS (GRHS x stmts cmd)
942 = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
943 stmts (addTickLHsCmd cmd)
944 ; return $ GRHS x stmts' expr' }
945
946 addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
947 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
948 addTickLCmdStmts stmts = do
949 (stmts, _) <- addTickLCmdStmts' stmts (return ())
950 return stmts
951
952 addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
953 -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
954 addTickLCmdStmts' lstmts res
955 = bindLocals binders $ do
956 lstmts' <- mapM (liftL addTickCmdStmt) lstmts
957 a <- res
958 return (lstmts', a)
959 where
960 binders = collectLStmtsBinders CollNoDictBinders lstmts
961
962 addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
963 addTickCmdStmt (BindStmt x pat c) =
964 liftM2 (BindStmt x)
965 (addTickLPat pat)
966 (addTickLHsCmd c)
967 addTickCmdStmt (LastStmt x c noret ret) =
968 liftM3 (LastStmt x)
969 (addTickLHsCmd c)
970 (pure noret)
971 (addTickSyntaxExpr hpcSrcSpan ret)
972 addTickCmdStmt (BodyStmt x c bind' guard') =
973 liftM3 (BodyStmt x)
974 (addTickLHsCmd c)
975 (addTickSyntaxExpr hpcSrcSpan bind')
976 (addTickSyntaxExpr hpcSrcSpan guard')
977 addTickCmdStmt (LetStmt x binds) =
978 liftM (LetStmt x)
979 (addTickHsLocalBinds binds)
980 addTickCmdStmt stmt@(RecStmt {})
981 = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)
982 ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
983 ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
984 ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
985 ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
986 , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
987 addTickCmdStmt ApplicativeStmt{} =
988 panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
989
990 -- Others should never happen in a command context.
991 addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
992
993 addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
994 addTickHsRecordBinds (HsRecFields fields dd)
995 = do { fields' <- mapM addTickHsRecField fields
996 ; return (HsRecFields fields' dd) }
997
998 addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)
999 -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))
1000 addTickHsRecField (L l (HsFieldBind x id expr pun))
1001 = do { expr' <- addTickLHsExpr expr
1002 ; return (L l (HsFieldBind x id expr' pun)) }
1003
1004 addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
1005 addTickArithSeqInfo (From e1) =
1006 liftM From
1007 (addTickLHsExpr e1)
1008 addTickArithSeqInfo (FromThen e1 e2) =
1009 liftM2 FromThen
1010 (addTickLHsExpr e1)
1011 (addTickLHsExpr e2)
1012 addTickArithSeqInfo (FromTo e1 e2) =
1013 liftM2 FromTo
1014 (addTickLHsExpr e1)
1015 (addTickLHsExpr e2)
1016 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
1017 liftM3 FromThenTo
1018 (addTickLHsExpr e1)
1019 (addTickLHsExpr e2)
1020 (addTickLHsExpr e3)
1021
1022 data TickTransState = TT { tickBoxCount:: !Int
1023 , mixEntries :: [MixEntry_]
1024 , ccIndices :: !CostCentreState
1025 }
1026
1027 addMixEntry :: MixEntry_ -> TM Int
1028 addMixEntry ent = do
1029 c <- tickBoxCount <$> getState
1030 setState $ \st ->
1031 st { tickBoxCount = c + 1
1032 , mixEntries = ent : mixEntries st
1033 }
1034 return c
1035
1036 data TickTransEnv = TTE { fileName :: FastString
1037 , density :: TickDensity
1038 , tte_dflags :: DynFlags
1039 , exports :: NameSet
1040 , inlines :: VarSet
1041 , declPath :: [String]
1042 , inScope :: VarSet
1043 , blackList :: Set RealSrcSpan
1044 , this_mod :: Module
1045 , tickishType :: TickishType
1046 }
1047
1048 -- deriving Show
1049
1050 data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
1051 deriving (Eq)
1052
1053 sourceNotesEnabled :: DynFlags -> Bool
1054 sourceNotesEnabled dflags =
1055 (debugLevel dflags > 0) || (gopt Opt_InfoTableMap dflags)
1056
1057 coveragePasses :: DynFlags -> [TickishType]
1058 coveragePasses dflags =
1059 ifa (breakpointsEnabled dflags) Breakpoints $
1060 ifa (gopt Opt_Hpc dflags) HpcTicks $
1061 ifa (sccProfilingEnabled dflags &&
1062 profAuto dflags /= NoProfAuto) ProfNotes $
1063 ifa (sourceNotesEnabled dflags) SourceNotes []
1064 where ifa f x xs | f = x:xs
1065 | otherwise = xs
1066
1067 -- | Should we produce 'Breakpoint' ticks?
1068 breakpointsEnabled :: DynFlags -> Bool
1069 breakpointsEnabled dflags = backend dflags == Interpreter
1070
1071 -- | Tickishs that only make sense when their source code location
1072 -- refers to the current file. This might not always be true due to
1073 -- LINE pragmas in the code - which would confuse at least HPC.
1074 tickSameFileOnly :: TickishType -> Bool
1075 tickSameFileOnly HpcTicks = True
1076 tickSameFileOnly _other = False
1077
1078 type FreeVars = OccEnv Id
1079 noFVs :: FreeVars
1080 noFVs = emptyOccEnv
1081
1082 -- Note [freevars]
1083 -- For breakpoints we want to collect the free variables of an
1084 -- expression for pinning on the HsTick. We don't want to collect
1085 -- *all* free variables though: in particular there's no point pinning
1086 -- on free variables that are will otherwise be in scope at the GHCi
1087 -- prompt, which means all top-level bindings. Unfortunately detecting
1088 -- top-level bindings isn't easy (collectHsBindsBinders on the top-level
1089 -- bindings doesn't do it), so we keep track of a set of "in-scope"
1090 -- variables in addition to the free variables, and the former is used
1091 -- to filter additions to the latter. This gives us complete control
1092 -- over what free variables we track.
1093
1094 newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
1095 deriving (Functor)
1096 -- a combination of a state monad (TickTransState) and a writer
1097 -- monad (FreeVars).
1098
1099 instance Applicative TM where
1100 pure a = TM $ \ _env st -> (a,noFVs,st)
1101 (<*>) = ap
1102
1103 instance Monad TM where
1104 (TM m) >>= k = TM $ \ env st ->
1105 case m env st of
1106 (r1,fv1,st1) ->
1107 case unTM (k r1) env st1 of
1108 (r2,fv2,st2) ->
1109 (r2, fv1 `plusOccEnv` fv2, st2)
1110
1111 instance HasDynFlags TM where
1112 getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
1113
1114 -- | Get the next HPC cost centre index for a given centre name
1115 getCCIndexM :: FastString -> TM CostCentreIndex
1116 getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
1117 ccIndices st
1118 in (idx, noFVs, st { ccIndices = is' })
1119
1120 getState :: TM TickTransState
1121 getState = TM $ \ _ st -> (st, noFVs, st)
1122
1123 setState :: (TickTransState -> TickTransState) -> TM ()
1124 setState f = TM $ \ _ st -> ((), noFVs, f st)
1125
1126 getEnv :: TM TickTransEnv
1127 getEnv = TM $ \ env st -> (env, noFVs, st)
1128
1129 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
1130 withEnv f (TM m) = TM $ \ env st ->
1131 case m (f env) st of
1132 (a, fvs, st') -> (a, fvs, st')
1133
1134 getDensity :: TM TickDensity
1135 getDensity = TM $ \env st -> (density env, noFVs, st)
1136
1137 ifDensity :: TickDensity -> TM a -> TM a -> TM a
1138 ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
1139
1140 getFreeVars :: TM a -> TM (FreeVars, a)
1141 getFreeVars (TM m)
1142 = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
1143
1144 freeVar :: Id -> TM ()
1145 freeVar id = TM $ \ env st ->
1146 if id `elemVarSet` inScope env
1147 then ((), unitOccEnv (nameOccName (idName id)) id, st)
1148 else ((), noFVs, st)
1149
1150 addPathEntry :: String -> TM a -> TM a
1151 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
1152
1153 getPathEntry :: TM [String]
1154 getPathEntry = declPath `liftM` getEnv
1155
1156 getFileName :: TM FastString
1157 getFileName = fileName `liftM` getEnv
1158
1159 isGoodSrcSpan' :: SrcSpan -> Bool
1160 isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos
1161 isGoodSrcSpan' (UnhelpfulSpan _) = False
1162
1163 isGoodTickSrcSpan :: SrcSpan -> TM Bool
1164 isGoodTickSrcSpan pos = do
1165 file_name <- getFileName
1166 tickish <- tickishType `liftM` getEnv
1167 let need_same_file = tickSameFileOnly tickish
1168 same_file = Just file_name == srcSpanFileName_maybe pos
1169 return (isGoodSrcSpan' pos && (not need_same_file || same_file))
1170
1171 ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
1172 ifGoodTickSrcSpan pos then_code else_code = do
1173 good <- isGoodTickSrcSpan pos
1174 if good then then_code else else_code
1175
1176 bindLocals :: [Id] -> TM a -> TM a
1177 bindLocals new_ids (TM m)
1178 = TM $ \ env st ->
1179 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
1180 (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
1181 where occs = [ nameOccName (idName id) | id <- new_ids ]
1182
1183 isBlackListed :: SrcSpan -> TM Bool
1184 isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)
1185 isBlackListed (UnhelpfulSpan _) = return False
1186
1187 -- the tick application inherits the source position of its
1188 -- expression argument to support nested box allocations
1189 allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
1190 -> TM (LHsExpr GhcTc)
1191 allocTickBox boxLabel countEntries topOnly pos m =
1192 ifGoodTickSrcSpan pos (do
1193 (fvs, e) <- getFreeVars m
1194 env <- getEnv
1195 tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
1196 return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))
1197 ) (do
1198 e <- m
1199 return (L (noAnnSrcSpan pos) e)
1200 )
1201
1202 -- the tick application inherits the source position of its
1203 -- expression argument to support nested box allocations
1204 allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
1205 -> TM (Maybe CoreTickish)
1206 allocATickBox boxLabel countEntries topOnly pos fvs =
1207 ifGoodTickSrcSpan pos (do
1208 let
1209 mydecl_path = case boxLabel of
1210 TopLevelBox x -> x
1211 LocalBox xs -> xs
1212 _ -> panic "allocATickBox"
1213 tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
1214 return (Just tickish)
1215 ) (return Nothing)
1216
1217
1218 mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
1219 -> TM CoreTickish
1220 mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
1221
1222 let ids = filter (not . isUnliftedType . idType) $ nonDetOccEnvElts fvs
1223 -- unlifted types cause two problems here:
1224 -- * we can't bind them at the GHCi prompt
1225 -- (bindLocalsAtBreakpoint already filters them out),
1226 -- * the simplifier might try to substitute a literal for
1227 -- the Id, and we can't handle that.
1228
1229 me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
1230
1231 cc_name | topOnly = head decl_path
1232 | otherwise = concat (intersperse "." decl_path)
1233
1234 dflags <- getDynFlags
1235 env <- getEnv
1236 case tickishType env of
1237 HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me
1238
1239 ProfNotes -> do
1240 let nm = mkFastString cc_name
1241 flavour <- HpcCC <$> getCCIndexM nm
1242 let cc = mkUserCC nm (this_mod env) pos flavour
1243 count = countEntries && gopt Opt_ProfCountEntries dflags
1244 return $ ProfNote cc count True{-scopes-}
1245
1246 Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids
1247
1248 SourceNotes | RealSrcSpan pos' _ <- pos ->
1249 return $ SourceNote pos' cc_name
1250
1251 _otherwise -> panic "mkTickish: bad source span!"
1252
1253
1254 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
1255 -> TM (LHsExpr GhcTc)
1256 allocBinTickBox boxLabel pos m = do
1257 env <- getEnv
1258 case tickishType env of
1259 HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m
1260 ifGoodTickSrcSpan pos
1261 (mkBinTickBoxHpc boxLabel pos e)
1262 (return e)
1263 _other -> allocTickBox (ExpBox False) False False pos m
1264
1265 mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
1266 -> TM (LHsExpr GhcTc)
1267 mkBinTickBoxHpc boxLabel pos e = do
1268 env <- getEnv
1269 binTick <- HsBinTick
1270 <$> addMixEntry (pos,declPath env, [],boxLabel True)
1271 <*> addMixEntry (pos,declPath env, [],boxLabel False)
1272 <*> pure e
1273 tick <- HpcTick (this_mod env)
1274 <$> addMixEntry (pos,declPath env, [],ExpBox False)
1275 let pos' = noAnnSrcSpan pos
1276 return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))
1277
1278 mkHpcPos :: SrcSpan -> HpcPos
1279 mkHpcPos pos@(RealSrcSpan s _)
1280 | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
1281 srcSpanStartCol s,
1282 srcSpanEndLine s,
1283 srcSpanEndCol s - 1)
1284 -- the end column of a SrcSpan is one
1285 -- greater than the last column of the
1286 -- span (see SrcLoc), whereas HPC
1287 -- expects to the column range to be
1288 -- inclusive, hence we subtract one above.
1289 mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
1290
1291 hpcSrcSpan :: SrcSpan
1292 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
1293
1294 matchesOneOfMany :: [LMatch GhcTc body] -> Bool
1295 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
1296 where
1297 matchCount :: LMatch GhcTc body -> Int
1298 matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
1299 = length grhss
1300
1301 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
1302
1303 -- For the hash value, we hash everything: the file name,
1304 -- the timestamp of the original source file, the tab stop,
1305 -- and the mix entries. We cheat, and hash the show'd string.
1306 -- This hash only has to be hashed at Mix creation time,
1307 -- and is for sanity checking only.
1308
1309 mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
1310 mixHash file tm tabstop entries = fromIntegral $ hashString
1311 (show $ Mix file tm 0 tabstop entries)
1312
1313 {-
1314 ************************************************************************
1315 * *
1316 * initialisation
1317 * *
1318 ************************************************************************
1319
1320 Each module compiled with -fhpc declares an initialisation function of
1321 the form `hpc_init_<module>()`, which is emitted into the _stub.c file
1322 and annotated with __attribute__((constructor)) so that it gets
1323 executed at startup time.
1324
1325 The function's purpose is to call hs_hpc_module to register this
1326 module with the RTS, and it looks something like this:
1327
1328 static void hpc_init_Main(void) __attribute__((constructor));
1329 static void hpc_init_Main(void)
1330 {extern StgWord64 _hpc_tickboxes_Main_hpc[];
1331 hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
1332 -}
1333
1334 hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub
1335 hpcInitCode _ _ (NoHpcInfo {}) = mempty
1336 hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)
1337 = CStub $ vcat
1338 [ text "static void hpc_init_" <> ppr this_mod
1339 <> text "(void) __attribute__((constructor));"
1340 , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
1341 , braces (vcat [
1342 text "extern StgWord64 " <> tickboxes <>
1343 text "[]" <> semi,
1344 text "hs_hpc_module" <>
1345 parens (hcat (punctuate comma [
1346 doubleQuotes full_name_str,
1347 int tickCount, -- really StgWord32
1348 int hashNo, -- really StgWord32
1349 tickboxes
1350 ])) <> semi
1351 ])
1352 ]
1353 where
1354 platform = targetPlatform dflags
1355 tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)
1356
1357 module_name = hcat (map (text.charToC) $ BS.unpack $
1358 bytesFS (moduleNameFS (moduleName this_mod)))
1359 package_name = hcat (map (text.charToC) $ BS.unpack $
1360 bytesFS (unitFS (moduleUnit this_mod)))
1361 full_name_str
1362 | moduleUnit this_mod == mainUnit
1363 = module_name
1364 | otherwise
1365 = package_name <> char '/' <> module_name