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