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