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