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