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