862e564aed12d38610f3bb5541767390283f1c41
[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 (HsAppTypeOut {}) = True
464 isGoodBreakExpr (OpApp {}) = True
465 isGoodBreakExpr _other = False
466
467 isCallSite :: HsExpr GhcTc -> Bool
468 isCallSite HsApp{} = True
469 isCallSite HsAppTypeOut{} = 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 matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
501 addTickHsExpr (HsLamCase mgs) = liftM HsLamCase (addTickMatchGroup True mgs)
502 addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
503 (addTickLHsExpr e2)
504 addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
505 (return ty)
506
507 addTickHsExpr (OpApp e1 e2 fix e3) =
508 liftM4 OpApp
509 (addTickLHsExpr e1)
510 (addTickLHsExprNever e2)
511 (return fix)
512 (addTickLHsExpr e3)
513 addTickHsExpr (NegApp e neg) =
514 liftM2 NegApp
515 (addTickLHsExpr e)
516 (addTickSyntaxExpr hpcSrcSpan neg)
517 addTickHsExpr (HsPar e) =
518 liftM HsPar (addTickLHsExprEvalInner e)
519 addTickHsExpr (SectionL e1 e2) =
520 liftM2 SectionL
521 (addTickLHsExpr e1)
522 (addTickLHsExprNever e2)
523 addTickHsExpr (SectionR e1 e2) =
524 liftM2 SectionR
525 (addTickLHsExprNever e1)
526 (addTickLHsExpr e2)
527 addTickHsExpr (ExplicitTuple es boxity) =
528 liftM2 ExplicitTuple
529 (mapM addTickTupArg es)
530 (return boxity)
531 addTickHsExpr (ExplicitSum tag arity e ty) = do
532 e' <- addTickLHsExpr e
533 return (ExplicitSum tag arity e' ty)
534 addTickHsExpr (HsCase e mgs) =
535 liftM2 HsCase
536 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
537 -- be evaluated.
538 (addTickMatchGroup False mgs)
539 addTickHsExpr (HsIf cnd e1 e2 e3) =
540 liftM3 (HsIf cnd)
541 (addBinTickLHsExpr (BinBox CondBinBox) e1)
542 (addTickLHsExprOptAlt True e2)
543 (addTickLHsExprOptAlt True e3)
544 addTickHsExpr (HsMultiIf ty alts)
545 = do { let isOneOfMany = case alts of [_] -> False; _ -> True
546 ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
547 ; return $ HsMultiIf ty alts' }
548 addTickHsExpr (HsLet (L l binds) e) =
549 bindLocals (collectLocalBinders binds) $
550 liftM2 (HsLet . L l)
551 (addTickHsLocalBinds binds) -- to think about: !patterns.
552 (addTickLHsExprLetBody e)
553 addTickHsExpr (HsDo cxt (L l stmts) srcloc)
554 = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
555 ; return (HsDo cxt (L l stmts') srcloc) }
556 where
557 forQual = case cxt of
558 ListComp -> Just $ BinBox QualBinBox
559 _ -> Nothing
560 addTickHsExpr (ExplicitList ty wit es) =
561 liftM3 ExplicitList
562 (return ty)
563 (addTickWit wit)
564 (mapM (addTickLHsExpr) es)
565 where addTickWit Nothing = return Nothing
566 addTickWit (Just fln)
567 = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
568 return (Just fln')
569 addTickHsExpr (ExplicitPArr ty es) =
570 liftM2 ExplicitPArr
571 (return ty)
572 (mapM (addTickLHsExpr) es)
573
574 addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
575
576 addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
577 = do { rec_binds' <- addTickHsRecordBinds rec_binds
578 ; return (expr { rcon_flds = rec_binds' }) }
579
580 addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
581 = do { e' <- addTickLHsExpr e
582 ; flds' <- mapM addTickHsRecField flds
583 ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
584
585 addTickHsExpr (ExprWithTySig e ty) =
586 liftM2 ExprWithTySig
587 (addTickLHsExprNever e) -- No need to tick the inner expression
588 -- for expressions with signatures
589 (return ty)
590 addTickHsExpr (ArithSeq ty wit arith_seq) =
591 liftM3 ArithSeq
592 (return ty)
593 (addTickWit wit)
594 (addTickArithSeqInfo arith_seq)
595 where addTickWit Nothing = return Nothing
596 addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
597 return (Just fl')
598
599 -- We might encounter existing ticks (multiple Coverage passes)
600 addTickHsExpr (HsTick t e) =
601 liftM (HsTick t) (addTickLHsExprNever e)
602 addTickHsExpr (HsBinTick t0 t1 e) =
603 liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
604
605 addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
606 e2 <- allocTickBox (ExpBox False) False False pos $
607 addTickHsExpr e0
608 return $ unLoc e2
609 addTickHsExpr (PArrSeq ty arith_seq) =
610 liftM2 PArrSeq
611 (return ty)
612 (addTickArithSeqInfo arith_seq)
613 addTickHsExpr (HsSCC src nm e) =
614 liftM3 HsSCC
615 (return src)
616 (return nm)
617 (addTickLHsExpr e)
618 addTickHsExpr (HsCoreAnn src nm e) =
619 liftM3 HsCoreAnn
620 (return src)
621 (return nm)
622 (addTickLHsExpr e)
623 addTickHsExpr e@(HsBracket {}) = return e
624 addTickHsExpr e@(HsTcBracketOut {}) = return e
625 addTickHsExpr e@(HsRnBracketOut {}) = return e
626 addTickHsExpr e@(HsSpliceE {}) = return e
627 addTickHsExpr (HsProc pat cmdtop) =
628 liftM2 HsProc
629 (addTickLPat pat)
630 (liftL (addTickHsCmdTop) cmdtop)
631 addTickHsExpr (HsWrap w e) =
632 liftM2 HsWrap
633 (return w)
634 (addTickHsExpr e) -- Explicitly no tick on inside
635
636 addTickHsExpr (ExprWithTySigOut e ty) =
637 liftM2 ExprWithTySigOut
638 (addTickLHsExprNever e) -- No need to tick the inner expression
639 (return ty) -- for expressions with signatures
640
641 -- Others should never happen in expression content.
642 addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
643
644 addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
645 addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
646 ; return (L l (Present e')) }
647 addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
648
649 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
650 -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
651 addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
652 let isOneOfMany = matchesOneOfMany matches
653 matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
654 return $ mg { mg_alts = L l matches' }
655
656 addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
657 -> TM (Match GhcTc (LHsExpr GhcTc))
658 addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
659 bindLocals (collectPatsBinders pats) $ do
660 gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
661 return $ match { m_grhss = gRHSs' }
662
663 addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
664 -> TM (GRHSs GhcTc (LHsExpr GhcTc))
665 addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
666 bindLocals binders $ do
667 local_binds' <- addTickHsLocalBinds local_binds
668 guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
669 return $ GRHSs guarded' (L l local_binds')
670 where
671 binders = collectLocalBinders local_binds
672
673 addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
674 -> TM (GRHS GhcTc (LHsExpr GhcTc))
675 addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
676 (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
677 (addTickGRHSBody isOneOfMany isLambda expr)
678 return $ GRHS stmts' expr'
679
680 addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
681 addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
682 d <- getDensity
683 case d of
684 TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr
685 TickAllFunctions | isLambda ->
686 addPathEntry "\\" $
687 allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
688 addTickHsExpr e0
689 _otherwise ->
690 addTickLHsExprRHS expr
691
692 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
693 -> TM [ExprLStmt GhcTc]
694 addTickLStmts isGuard stmts = do
695 (stmts, _) <- addTickLStmts' isGuard stmts (return ())
696 return stmts
697
698 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
699 -> TM ([ExprLStmt GhcTc], a)
700 addTickLStmts' isGuard lstmts res
701 = bindLocals (collectLStmtsBinders lstmts) $
702 do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
703 ; a <- res
704 ; return (lstmts', a) }
705
706 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
707 -> TM (Stmt GhcTc (LHsExpr GhcTc))
708 addTickStmt _isGuard (LastStmt e noret ret) = do
709 liftM3 LastStmt
710 (addTickLHsExpr e)
711 (pure noret)
712 (addTickSyntaxExpr hpcSrcSpan ret)
713 addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
714 liftM5 BindStmt
715 (addTickLPat pat)
716 (addTickLHsExprRHS e)
717 (addTickSyntaxExpr hpcSrcSpan bind)
718 (addTickSyntaxExpr hpcSrcSpan fail)
719 (return ty)
720 addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
721 liftM4 BodyStmt
722 (addTick isGuard e)
723 (addTickSyntaxExpr hpcSrcSpan bind')
724 (addTickSyntaxExpr hpcSrcSpan guard')
725 (return ty)
726 addTickStmt _isGuard (LetStmt (L l binds)) = do
727 liftM (LetStmt . L l)
728 (addTickHsLocalBinds binds)
729 addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
730 liftM4 ParStmt
731 (mapM (addTickStmtAndBinders isGuard) pairs)
732 (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
733 (addTickSyntaxExpr hpcSrcSpan bindExpr)
734 (return ty)
735 addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
736 args' <- mapM (addTickApplicativeArg isGuard) args
737 return (ApplicativeStmt args' mb_join body_ty)
738
739 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
740 , trS_by = by, trS_using = using
741 , trS_ret = returnExpr, trS_bind = bindExpr
742 , trS_fmap = liftMExpr }) = do
743 t_s <- addTickLStmts isGuard stmts
744 t_y <- fmapMaybeM addTickLHsExprRHS by
745 t_u <- addTickLHsExprRHS using
746 t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
747 t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
748 L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
749 return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
750 , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
751
752 addTickStmt isGuard stmt@(RecStmt {})
753 = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
754 ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
755 ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
756 ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
757 ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
758 , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
759
760 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
761 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
762 | otherwise = addTickLHsExprRHS e
763
764 addTickApplicativeArg
765 :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
766 -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc GhcTc)
767 addTickApplicativeArg isGuard (op, arg) =
768 liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
769 where
770 addTickArg (ApplicativeArgOne pat expr isBody) =
771 ApplicativeArgOne
772 <$> addTickLPat pat
773 <*> addTickLHsExpr expr
774 <*> pure isBody
775 addTickArg (ApplicativeArgMany stmts ret pat) =
776 ApplicativeArgMany
777 <$> addTickLStmts isGuard stmts
778 <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
779 <*> addTickLPat pat
780
781 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
782 -> TM (ParStmtBlock GhcTc GhcTc)
783 addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
784 liftM3 ParStmtBlock
785 (addTickLStmts isGuard stmts)
786 (return ids)
787 (addTickSyntaxExpr hpcSrcSpan returnExpr)
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 a -> TM (HsValBindsLR GhcTc b)
799 addTickHsValBinds (ValBindsOut binds sigs) =
800 liftM2 ValBindsOut
801 (mapM (\ (rec,binds') ->
802 liftM2 (,)
803 (return rec)
804 (addTickLHsBinds binds'))
805 binds)
806 (return sigs)
807 addTickHsValBinds _ = panic "addTickHsValBinds"
808
809 addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
810 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
811 liftM2 IPBinds
812 (mapM (liftL (addTickIPBind)) ipbinds)
813 (return dictbinds)
814
815 addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
816 addTickIPBind (IPBind nm e) =
817 liftM2 IPBind
818 (return nm)
819 (addTickLHsExpr e)
820
821 -- There is no location here, so we might need to use a context location??
822 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
823 addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
824 L _ x' <- addTickLHsExpr (L pos x)
825 return $ syn { syn_expr = x' }
826 -- we do not walk into patterns.
827 addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
828 addTickLPat pat = return pat
829
830 addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
831 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
832 liftM4 HsCmdTop
833 (addTickLHsCmd cmd)
834 (return tys)
835 (return ty)
836 (return syntaxtable)
837
838 addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
839 addTickLHsCmd (L pos c0) = do
840 c1 <- addTickHsCmd c0
841 return $ L pos c1
842
843 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
844 addTickHsCmd (HsCmdLam matchgroup) =
845 liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
846 addTickHsCmd (HsCmdApp c e) =
847 liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
848 {-
849 addTickHsCmd (OpApp e1 c2 fix c3) =
850 liftM4 OpApp
851 (addTickLHsExpr e1)
852 (addTickLHsCmd c2)
853 (return fix)
854 (addTickLHsCmd c3)
855 -}
856 addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
857 addTickHsCmd (HsCmdCase e mgs) =
858 liftM2 HsCmdCase
859 (addTickLHsExpr e)
860 (addTickCmdMatchGroup mgs)
861 addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
862 liftM3 (HsCmdIf cnd)
863 (addBinTickLHsExpr (BinBox CondBinBox) e1)
864 (addTickLHsCmd c2)
865 (addTickLHsCmd c3)
866 addTickHsCmd (HsCmdLet (L l binds) c) =
867 bindLocals (collectLocalBinders binds) $
868 liftM2 (HsCmdLet . L l)
869 (addTickHsLocalBinds binds) -- to think about: !patterns.
870 (addTickLHsCmd c)
871 addTickHsCmd (HsCmdDo (L l stmts) srcloc)
872 = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
873 ; return (HsCmdDo (L l stmts') srcloc) }
874
875 addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
876 liftM5 HsCmdArrApp
877 (addTickLHsExpr e1)
878 (addTickLHsExpr e2)
879 (return ty1)
880 (return arr_ty)
881 (return lr)
882 addTickHsCmd (HsCmdArrForm e f fix cmdtop) =
883 liftM4 HsCmdArrForm
884 (addTickLHsExpr e)
885 (return f)
886 (return fix)
887 (mapM (liftL (addTickHsCmdTop)) cmdtop)
888
889 addTickHsCmd (HsCmdWrap w cmd)
890 = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
891
892 -- Others should never happen in a command context.
893 --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
894
895 addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
896 -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
897 addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
898 matches' <- mapM (liftL addTickCmdMatch) matches
899 return $ mg { mg_alts = L l matches' }
900
901 addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
902 addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
903 bindLocals (collectPatsBinders pats) $ do
904 gRHSs' <- addTickCmdGRHSs gRHSs
905 return $ match { m_grhss = gRHSs' }
906
907 addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
908 addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
909 bindLocals binders $ do
910 local_binds' <- addTickHsLocalBinds local_binds
911 guarded' <- mapM (liftL addTickCmdGRHS) guarded
912 return $ GRHSs guarded' (L l local_binds')
913 where
914 binders = collectLocalBinders local_binds
915
916 addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
917 -- The *guards* are *not* Cmds, although the body is
918 -- C.f. addTickGRHS for the BinBox stuff
919 addTickCmdGRHS (GRHS stmts cmd)
920 = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
921 stmts (addTickLHsCmd cmd)
922 ; return $ GRHS stmts' expr' }
923
924 addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
925 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
926 addTickLCmdStmts stmts = do
927 (stmts, _) <- addTickLCmdStmts' stmts (return ())
928 return stmts
929
930 addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
931 -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
932 addTickLCmdStmts' lstmts res
933 = bindLocals binders $ do
934 lstmts' <- mapM (liftL addTickCmdStmt) lstmts
935 a <- res
936 return (lstmts', a)
937 where
938 binders = collectLStmtsBinders lstmts
939
940 addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
941 addTickCmdStmt (BindStmt pat c bind fail ty) = do
942 liftM5 BindStmt
943 (addTickLPat pat)
944 (addTickLHsCmd c)
945 (return bind)
946 (return fail)
947 (return ty)
948 addTickCmdStmt (LastStmt c noret ret) = do
949 liftM3 LastStmt
950 (addTickLHsCmd c)
951 (pure noret)
952 (addTickSyntaxExpr hpcSrcSpan ret)
953 addTickCmdStmt (BodyStmt c bind' guard' ty) = do
954 liftM4 BodyStmt
955 (addTickLHsCmd c)
956 (addTickSyntaxExpr hpcSrcSpan bind')
957 (addTickSyntaxExpr hpcSrcSpan guard')
958 (return ty)
959 addTickCmdStmt (LetStmt (L l binds)) = do
960 liftM (LetStmt . L l)
961 (addTickHsLocalBinds binds)
962 addTickCmdStmt stmt@(RecStmt {})
963 = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
964 ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
965 ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
966 ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
967 ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
968 , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
969 addTickCmdStmt ApplicativeStmt{} =
970 panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
971
972 -- Others should never happen in a command context.
973 addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
974
975 addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
976 addTickHsRecordBinds (HsRecFields fields dd)
977 = do { fields' <- mapM addTickHsRecField fields
978 ; return (HsRecFields fields' dd) }
979
980 addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
981 -> TM (LHsRecField' id (LHsExpr GhcTc))
982 addTickHsRecField (L l (HsRecField id expr pun))
983 = do { expr' <- addTickLHsExpr expr
984 ; return (L l (HsRecField id expr' pun)) }
985
986
987 addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
988 addTickArithSeqInfo (From e1) =
989 liftM From
990 (addTickLHsExpr e1)
991 addTickArithSeqInfo (FromThen e1 e2) =
992 liftM2 FromThen
993 (addTickLHsExpr e1)
994 (addTickLHsExpr e2)
995 addTickArithSeqInfo (FromTo e1 e2) =
996 liftM2 FromTo
997 (addTickLHsExpr e1)
998 (addTickLHsExpr e2)
999 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
1000 liftM3 FromThenTo
1001 (addTickLHsExpr e1)
1002 (addTickLHsExpr e2)
1003 (addTickLHsExpr e3)
1004
1005 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
1006 liftL f (L loc a) = do
1007 a' <- f a
1008 return $ L loc a'
1009
1010 data TickTransState = TT { tickBoxCount:: Int
1011 , mixEntries :: [MixEntry_]
1012 , uniqSupply :: UniqSupply
1013 }
1014
1015 data TickTransEnv = TTE { fileName :: FastString
1016 , density :: TickDensity
1017 , tte_dflags :: DynFlags
1018 , exports :: NameSet
1019 , inlines :: VarSet
1020 , declPath :: [String]
1021 , inScope :: VarSet
1022 , blackList :: Map SrcSpan ()
1023 , this_mod :: Module
1024 , tickishType :: TickishType
1025 }
1026
1027 -- deriving Show
1028
1029 data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
1030 deriving (Eq)
1031
1032 coveragePasses :: DynFlags -> [TickishType]
1033 coveragePasses dflags =
1034 ifa (hscTarget dflags == HscInterpreted) Breakpoints $
1035 ifa (gopt Opt_Hpc dflags) HpcTicks $
1036 ifa (gopt Opt_SccProfilingOn dflags &&
1037 profAuto dflags /= NoProfAuto) ProfNotes $
1038 ifa (debugLevel dflags > 0) SourceNotes []
1039 where ifa f x xs | f = x:xs
1040 | otherwise = xs
1041
1042 -- | Tickishs that only make sense when their source code location
1043 -- refers to the current file. This might not always be true due to
1044 -- LINE pragmas in the code - which would confuse at least HPC.
1045 tickSameFileOnly :: TickishType -> Bool
1046 tickSameFileOnly HpcTicks = True
1047 tickSameFileOnly _other = False
1048
1049 type FreeVars = OccEnv Id
1050 noFVs :: FreeVars
1051 noFVs = emptyOccEnv
1052
1053 -- Note [freevars]
1054 -- For breakpoints we want to collect the free variables of an
1055 -- expression for pinning on the HsTick. We don't want to collect
1056 -- *all* free variables though: in particular there's no point pinning
1057 -- on free variables that are will otherwise be in scope at the GHCi
1058 -- prompt, which means all top-level bindings. Unfortunately detecting
1059 -- top-level bindings isn't easy (collectHsBindsBinders on the top-level
1060 -- bindings doesn't do it), so we keep track of a set of "in-scope"
1061 -- variables in addition to the free variables, and the former is used
1062 -- to filter additions to the latter. This gives us complete control
1063 -- over what free variables we track.
1064
1065 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
1066 -- a combination of a state monad (TickTransState) and a writer
1067 -- monad (FreeVars).
1068
1069 instance Functor TM where
1070 fmap = liftM
1071
1072 instance Applicative TM where
1073 pure a = TM $ \ _env st -> (a,noFVs,st)
1074 (<*>) = ap
1075
1076 instance Monad TM where
1077 (TM m) >>= k = TM $ \ env st ->
1078 case m env st of
1079 (r1,fv1,st1) ->
1080 case unTM (k r1) env st1 of
1081 (r2,fv2,st2) ->
1082 (r2, fv1 `plusOccEnv` fv2, st2)
1083
1084 instance HasDynFlags TM where
1085 getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
1086
1087 instance MonadUnique TM where
1088 getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)
1089 getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)
1090 in (u, noFVs, st { uniqSupply = us' })
1091
1092 getState :: TM TickTransState
1093 getState = TM $ \ _ st -> (st, noFVs, st)
1094
1095 setState :: (TickTransState -> TickTransState) -> TM ()
1096 setState f = TM $ \ _ st -> ((), noFVs, f st)
1097
1098 getEnv :: TM TickTransEnv
1099 getEnv = TM $ \ env st -> (env, noFVs, st)
1100
1101 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
1102 withEnv f (TM m) = TM $ \ env st ->
1103 case m (f env) st of
1104 (a, fvs, st') -> (a, fvs, st')
1105
1106 getDensity :: TM TickDensity
1107 getDensity = TM $ \env st -> (density env, noFVs, st)
1108
1109 ifDensity :: TickDensity -> TM a -> TM a -> TM a
1110 ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
1111
1112 getFreeVars :: TM a -> TM (FreeVars, a)
1113 getFreeVars (TM m)
1114 = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
1115
1116 freeVar :: Id -> TM ()
1117 freeVar id = TM $ \ env st ->
1118 if id `elemVarSet` inScope env
1119 then ((), unitOccEnv (nameOccName (idName id)) id, st)
1120 else ((), noFVs, st)
1121
1122 addPathEntry :: String -> TM a -> TM a
1123 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
1124
1125 getPathEntry :: TM [String]
1126 getPathEntry = declPath `liftM` getEnv
1127
1128 getFileName :: TM FastString
1129 getFileName = fileName `liftM` getEnv
1130
1131 isGoodSrcSpan' :: SrcSpan -> Bool
1132 isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
1133 isGoodSrcSpan' (UnhelpfulSpan _) = False
1134
1135 isGoodTickSrcSpan :: SrcSpan -> TM Bool
1136 isGoodTickSrcSpan pos = do
1137 file_name <- getFileName
1138 tickish <- tickishType `liftM` getEnv
1139 let need_same_file = tickSameFileOnly tickish
1140 same_file = Just file_name == srcSpanFileName_maybe pos
1141 return (isGoodSrcSpan' pos && (not need_same_file || same_file))
1142
1143 ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
1144 ifGoodTickSrcSpan pos then_code else_code = do
1145 good <- isGoodTickSrcSpan pos
1146 if good then then_code else else_code
1147
1148 bindLocals :: [Id] -> TM a -> TM a
1149 bindLocals new_ids (TM m)
1150 = TM $ \ env st ->
1151 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
1152 (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
1153 where occs = [ nameOccName (idName id) | id <- new_ids ]
1154
1155 isBlackListed :: SrcSpan -> TM Bool
1156 isBlackListed pos = TM $ \ env st ->
1157 case Map.lookup pos (blackList env) of
1158 Nothing -> (False,noFVs,st)
1159 Just () -> (True,noFVs,st)
1160
1161 -- the tick application inherits the source position of its
1162 -- expression argument to support nested box allocations
1163 allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
1164 -> TM (LHsExpr GhcTc)
1165 allocTickBox boxLabel countEntries topOnly pos m =
1166 ifGoodTickSrcSpan pos (do
1167 (fvs, e) <- getFreeVars m
1168 env <- getEnv
1169 tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
1170 return (L pos (HsTick tickish (L pos e)))
1171 ) (do
1172 e <- m
1173 return (L pos e)
1174 )
1175
1176 -- the tick application inherits the source position of its
1177 -- expression argument to support nested box allocations
1178 allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
1179 -> TM (Maybe (Tickish Id))
1180 allocATickBox boxLabel countEntries topOnly pos fvs =
1181 ifGoodTickSrcSpan pos (do
1182 let
1183 mydecl_path = case boxLabel of
1184 TopLevelBox x -> x
1185 LocalBox xs -> xs
1186 _ -> panic "allocATickBox"
1187 tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
1188 return (Just tickish)
1189 ) (return Nothing)
1190
1191
1192 mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
1193 -> TM (Tickish Id)
1194 mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
1195
1196 let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
1197 -- unlifted types cause two problems here:
1198 -- * we can't bind them at the GHCi prompt
1199 -- (bindLocalsAtBreakpoint already fliters them out),
1200 -- * the simplifier might try to substitute a literal for
1201 -- the Id, and we can't handle that.
1202
1203 me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
1204
1205 cc_name | topOnly = head decl_path
1206 | otherwise = concat (intersperse "." decl_path)
1207
1208 dflags <- getDynFlags
1209 env <- getEnv
1210 case tickishType env of
1211 HpcTicks -> do
1212 c <- liftM tickBoxCount getState
1213 setState $ \st -> st { tickBoxCount = c + 1
1214 , mixEntries = me : mixEntries st }
1215 return $ HpcTick (this_mod env) c
1216
1217 ProfNotes -> do
1218 ccUnique <- getUniqueM
1219 let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique
1220 count = countEntries && gopt Opt_ProfCountEntries dflags
1221 return $ ProfNote cc count True{-scopes-}
1222
1223 Breakpoints -> do
1224 c <- liftM tickBoxCount getState
1225 setState $ \st -> st { tickBoxCount = c + 1
1226 , mixEntries = me:mixEntries st }
1227 return $ Breakpoint c ids
1228
1229 SourceNotes | RealSrcSpan pos' <- pos ->
1230 return $ SourceNote pos' cc_name
1231
1232 _otherwise -> panic "mkTickish: bad source span!"
1233
1234
1235 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
1236 -> TM (LHsExpr GhcTc)
1237 allocBinTickBox boxLabel pos m = do
1238 env <- getEnv
1239 case tickishType env of
1240 HpcTicks -> do e <- liftM (L pos) m
1241 ifGoodTickSrcSpan pos
1242 (mkBinTickBoxHpc boxLabel pos e)
1243 (return e)
1244 _other -> allocTickBox (ExpBox False) False False pos m
1245
1246 mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
1247 -> TM (LHsExpr GhcTc)
1248 mkBinTickBoxHpc boxLabel pos e =
1249 TM $ \ env st ->
1250 let meT = (pos,declPath env, [],boxLabel True)
1251 meF = (pos,declPath env, [],boxLabel False)
1252 meE = (pos,declPath env, [],ExpBox False)
1253 c = tickBoxCount st
1254 mes = mixEntries st
1255 in
1256 ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
1257 -- notice that F and T are reversed,
1258 -- because we are building the list in
1259 -- reverse...
1260 , noFVs
1261 , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
1262 )
1263
1264 mkHpcPos :: SrcSpan -> HpcPos
1265 mkHpcPos pos@(RealSrcSpan s)
1266 | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
1267 srcSpanStartCol s,
1268 srcSpanEndLine s,
1269 srcSpanEndCol s - 1)
1270 -- the end column of a SrcSpan is one
1271 -- greater than the last column of the
1272 -- span (see SrcLoc), whereas HPC
1273 -- expects to the column range to be
1274 -- inclusive, hence we subtract one above.
1275 mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
1276
1277 hpcSrcSpan :: SrcSpan
1278 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
1279
1280 matchesOneOfMany :: [LMatch GhcTc body] -> Bool
1281 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
1282 where
1283 matchCount (L _ (Match { m_grhss = GRHSs grhss _binds })) = length grhss
1284
1285 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
1286
1287 -- For the hash value, we hash everything: the file name,
1288 -- the timestamp of the original source file, the tab stop,
1289 -- and the mix entries. We cheat, and hash the show'd string.
1290 -- This hash only has to be hashed at Mix creation time,
1291 -- and is for sanity checking only.
1292
1293 mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
1294 mixHash file tm tabstop entries = fromIntegral $ hashString
1295 (show $ Mix file tm 0 tabstop entries)
1296
1297 {-
1298 ************************************************************************
1299 * *
1300 * initialisation
1301 * *
1302 ************************************************************************
1303
1304 Each module compiled with -fhpc declares an initialisation function of
1305 the form `hpc_init_<module>()`, which is emitted into the _stub.c file
1306 and annotated with __attribute__((constructor)) so that it gets
1307 executed at startup time.
1308
1309 The function's purpose is to call hs_hpc_module to register this
1310 module with the RTS, and it looks something like this:
1311
1312 static void hpc_init_Main(void) __attribute__((constructor));
1313 static void hpc_init_Main(void)
1314 {extern StgWord64 _hpc_tickboxes_Main_hpc[];
1315 hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
1316 -}
1317
1318 hpcInitCode :: Module -> HpcInfo -> SDoc
1319 hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
1320 hpcInitCode this_mod (HpcInfo tickCount hashNo)
1321 = vcat
1322 [ text "static void hpc_init_" <> ppr this_mod
1323 <> text "(void) __attribute__((constructor));"
1324 , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
1325 , braces (vcat [
1326 text "extern StgWord64 " <> tickboxes <>
1327 text "[]" <> semi,
1328 text "hs_hpc_module" <>
1329 parens (hcat (punctuate comma [
1330 doubleQuotes full_name_str,
1331 int tickCount, -- really StgWord32
1332 int hashNo, -- really StgWord32
1333 tickboxes
1334 ])) <> semi
1335 ])
1336 ]
1337 where
1338 tickboxes = ppr (mkHpcTicksLabel $ this_mod)
1339
1340 module_name = hcat (map (text.charToC) $
1341 bytesFS (moduleNameFS (Module.moduleName this_mod)))
1342 package_name = hcat (map (text.charToC) $
1343 bytesFS (unitIdFS (moduleUnitId this_mod)))
1344 full_name_str
1345 | moduleUnitId this_mod == mainUnitId
1346 = module_name
1347 | otherwise
1348 = package_name <> char '/' <> module_name