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