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