Coverage.hs 51 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4 5
{-
(c) Galois, 2006
(c) University of Glasgow, 2007
-}

Ryan Scott's avatar
Ryan Scott committed
6
{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
7

8
module Coverage (addTicksToBinds, hpcInitCode) where
andy@galois.com's avatar
andy@galois.com committed
9

10 11
import GhcPrelude as Prelude

12 13
import qualified GHCi
import GHCi.RemoteTypes
14 15 16
import Data.Array
import ByteCodeTypes
import GHC.Stack.CCS
17
import Type
andy@galois.com's avatar
andy@galois.com committed
18 19 20
import HsSyn
import Module
import Outputable
21
import DynFlags
Richard Eisenberg's avatar
Richard Eisenberg committed
22
import ConLike
Ian Lynagh's avatar
Ian Lynagh committed
23
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
24
import SrcLoc
25
import ErrUtils
26
import NameSet hiding (FreeVars)
andy@galois.com's avatar
andy@galois.com committed
27 28
import Name
import Bag
29 30
import CostCentre
import CoreSyn
31
import Id
32
import VarSet
33 34
import Data.List
import FastString
35
import HscTypes
36
import TyCon
37
import UniqSupply
38
import BasicTypes
39
import MonadUtils
40
import Maybes
41 42
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
43

44 45
import Data.Time
import System.Directory
46

47 48 49
import Trace.Hpc.Mix
import Trace.Hpc.Util

50 51
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
52

Austin Seipp's avatar
Austin Seipp committed
53 54 55 56 57 58 59
{-
************************************************************************
*                                                                      *
*              The main function: addTicksToBinds
*                                                                      *
************************************************************************
-}
60

61
addTicksToBinds
62
        :: HscEnv
63
        -> Module
64 65 66 67 68
        -> ModLocation          -- ... off the current module
        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
                                -- isExportedId doesn't work yet (the desugarer
                                -- hasn't set it), so we have to work from this set.
        -> [TyCon]              -- Type constructor in this module
69 70
        -> LHsBinds GhcTc
        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
71

72 73 74
addTicksToBinds hsc_env mod mod_loc exports tyCons binds
  | let dflags = hsc_dflags hsc_env
        passes = coveragePasses dflags, not (null passes),
75 76
    Just orig_file <- ml_hs_file mod_loc,
    not ("boot" `isSuffixOf` orig_file) = do
77

78
     us <- mkSplitUniqSupply 'C' -- for cost centres
79
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
80

81 82
          tickPass tickish (binds,st) =
            let env = TTE
83
                      { fileName     = mkFastString orig_file2
84
                      , declPath     = []
85
                      , tte_dflags   = dflags
86
                      , exports      = exports
87
                      , inlines      = emptyVarSet
88
                      , inScope      = emptyVarSet
89 90 91
                      , blackList    = Map.fromList
                                          [ (getSrcSpan (tyConName tyCon),())
                                          | tyCon <- tyCons ]
92
                      , density      = mkDensity tickish dflags
93
                      , this_mod     = mod
94
                      , tickishType  = tickish
95
}
96 97 98 99 100 101 102 103 104 105 106
                (binds',_,st') = unTM (addTickLHsBinds binds) env st
            in (binds', st')

          initState = TT { tickBoxCount = 0
                         , mixEntries   = []
                         , uniqSupply   = us
                         }

          (binds1,st) = foldr tickPass (binds, initState) passes

     let tickCount = tickBoxCount st
107 108 109
         entries = reverse $ mixEntries st
     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
     modBreaks <- mkModBreaks hsc_env mod tickCount entries
andy@galois.com's avatar
andy@galois.com committed
110

111
     when (dopt Opt_D_dump_ticked dflags) $
Ben Gamari's avatar
Ben Gamari committed
112
         putLogMsg dflags NoReason SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
113
             (defaultDumpStyle dflags) (pprLHsBinds binds1)
114

115
     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
andy@galois.com's avatar
andy@galois.com committed
116

117
  | otherwise = return (binds, emptyHpcInfo False, Nothing)
118

119
guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
120 121 122
guessSourceFile binds orig_file =
     -- Try look for a file generated from a .hsc file to a
     -- .hs file, by peeking ahead.
123
     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
124 125 126 127 128 129 130 131
                                 srcSpanFileName_maybe pos : rest) [] binds
     in
     case top_pos of
        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
                      -> unpackFS file_name
        _ -> orig_file


132 133 134
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks hsc_env mod count entries
  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
135
    breakArray <- GHCi.newBreakArray hsc_env (length entries)
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
    ccs <- mkCCSArray hsc_env mod count entries
    let
           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
    return emptyModBreaks
                       { modBreaks_flags = breakArray
                       , modBreaks_locs  = locsTicks
                       , modBreaks_vars  = varsTicks
                       , modBreaks_decls = declsTicks
                       , modBreaks_ccs   = ccs
                       }
  | otherwise = return emptyModBreaks

mkCCSArray
  :: HscEnv -> Module -> Int -> [MixEntry_]
152
  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
153
mkCCSArray hsc_env modul count entries = do
154
  if interpreterProfiled dflags
155
    then do
156 157
      let module_str = moduleNameString (moduleName modul)
      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
158 159 160 161
      return (listArray (0,count-1) costcentres)
    else do
      return (listArray (0,-1) [])
 where
162 163 164 165
    dflags = hsc_dflags hsc_env
    mk_one (srcspan, decl_path, _, _) = (name, src)
      where name = concat (intersperse "." decl_path)
            src = showSDoc dflags (ppr srcspan)
166 167 168 169


writeMixEntries
  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
170
writeMixEntries dflags mod count entries filename
ian@well-typed.com's avatar
ian@well-typed.com committed
171
  | not (gopt Opt_Hpc dflags) = return 0
172 173 174 175 176 177
  | otherwise   = do
        let
            hpc_dir = hpcDir dflags
            mod_name = moduleNameString (moduleName mod)

            hpc_mod_dir
178 179
              | moduleUnitId mod == mainUnitId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
180

181 182
            tabStop = 8 -- <tab> counts as a normal char in GHC's
                        -- location ranges.
183 184

        createDirectoryIfMissing True hpc_mod_dir
185
        modTime <- getModificationUTCTime filename
186
        let entries' = [ (hpcPos, box)
187
                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
188
        when (entries' `lengthIsNot` count) $ do
189 190
          panic "the number of .mix entries are inconsistent"
        let hashNo = mixHash filename modTime tabStop entries'
191
        mixCreate hpc_mod_dir mod_name
192 193 194 195 196 197 198 199 200 201 202 203 204
                       $ Mix filename modTime (toHash hashNo) tabStop entries'
        return hashNo


-- -----------------------------------------------------------------------------
-- TickDensity: where to insert ticks

data TickDensity
  = TickForCoverage       -- for Hpc
  | TickForBreakPoints    -- for GHCi
  | TickAllFunctions      -- for -prof-auto-all
  | TickTopFunctions      -- for -prof-auto-top
  | TickExportedFunctions -- for -prof-auto-exported
205
  | TickCallSites         -- for stack tracing
206 207
  deriving Eq

208 209 210 211 212 213 214 215 216 217 218 219
mkDensity :: TickishType -> DynFlags -> TickDensity
mkDensity tickish dflags = case tickish of
  HpcTicks             -> TickForCoverage
  SourceNotes          -> TickForCoverage
  Breakpoints          -> TickForBreakPoints
  ProfNotes ->
    case profAuto dflags of
      ProfAutoAll      -> TickAllFunctions
      ProfAutoTop      -> TickTopFunctions
      ProfAutoExports  -> TickExportedFunctions
      ProfAutoCalls    -> TickCallSites
      _other           -> panic "mkDensity"
220 221 222 223 224 225 226 227 228

-- | Decide whether to add a tick to a binding or not.
shouldTickBind  :: TickDensity
                -> Bool         -- top level?
                -> Bool         -- exported?
                -> Bool         -- simple pat bind?
                -> Bool         -- INLINE pragma?
                -> Bool

229
shouldTickBind density top_lev exported _simple_pat inline
230
 = case density of
231
      TickForBreakPoints    -> False
232 233 234 235 236 237
        -- we never add breakpoints to simple pattern bindings
        -- (there's always a tick on the rhs anyway).
      TickAllFunctions      -> not inline
      TickTopFunctions      -> top_lev && not inline
      TickExportedFunctions -> exported && not inline
      TickForCoverage       -> True
238
      TickCallSites         -> False
239 240 241 242 243 244 245 246 247

shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind density top_lev
  = case density of
      TickForBreakPoints    -> False
      TickAllFunctions      -> True
      TickTopFunctions      -> top_lev
      TickExportedFunctions -> False
      TickForCoverage       -> False
248
      TickCallSites         -> False
249 250 251

-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
andy@galois.com's avatar
andy@galois.com committed
252

253
addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
254
addTickLHsBinds = mapBagM addTickLHsBind
andy@galois.com's avatar
andy@galois.com committed
255

256
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
257 258 259
addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                                       abs_exports = abs_exports })) = do
  withEnv add_exports $ do
260
  withEnv add_inlines $ do
261 262
  binds' <- addTickLHsBinds binds
  return $ L pos $ bind { abs_binds = binds' }
263 264 265 266 267 268 269
 where
   -- in AbsBinds, the Id on each binding is not the actual top-level
   -- Id that we are defining, they are related by the abs_exports
   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
   -- to add the local Ids to the set of exported Names so that we know to
   -- tick the right bindings.
   add_exports env =
270
     env{ exports = exports env `extendNameSetList`
271 272 273 274
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

275
   -- See Note [inline sccs]
276 277 278 279
   add_inlines env =
     env{ inlines = inlines env `extendVarSetList`
                      [ mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
280
                      , isInlinePragma (idInlinePragma pid) ] }
281

282
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
andy@galois.com's avatar
andy@galois.com committed
283 284
  let name = getOccString id
  decl_path <- getPathEntry
285 286 287
  density <- getDensity

  inline_ids <- liftM inlines getEnv
288 289
  -- See Note [inline sccs]
  let inline   = isInlinePragma (idInlinePragma id)
290 291 292
                 || id `elemVarSet` inline_ids

  -- See Note [inline sccs]
293 294
  tickish <- tickishType `liftM` getEnv
  if inline && tickish == ProfNotes then return (L pos funBind) else do
andy@galois.com's avatar
andy@galois.com committed
295

296
  (fvs, mg@(MG { mg_alts = matches' })) <-
297
        getFreeVars $
298
        addPathEntry name $
299
        addTickMatchGroup False (fun_matches funBind)
300

301
  blackListed <- isBlackListed pos
302
  exported_names <- liftM exports getEnv
303 304

  -- We don't want to generate code for blacklisted positions
305 306 307 308 309 310 311 312 313 314 315 316 317
  -- We don't want redundant ticks on simple pattern bindings
  -- We don't want to tick non-exported bindings in TickExportedFunctions
  let simple = isSimplePatBind funBind
      toplev = null decl_path
      exported = idName id `elemNameSet` exported_names

  tick <- if not blackListed &&
               shouldTickBind density toplev exported simple inline
             then
                bindTick density name pos fvs
             else
                return Nothing

318
  let mbCons = maybe Prelude.id (:)
319
  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
320
                           , fun_tick = tick `mbCons` fun_tick funBind }
321

322
   where
323 324
   -- a binding is a simple pattern binding if it is a funbind with
   -- zero patterns
325 326
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
327 328

-- TODO: Revisit this
329
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
andy@galois.com's avatar
andy@galois.com committed
330
  let name = "(...)"
331
  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
332
  let pat' = pat { pat_rhs = rhs'}
333

334
  -- Should create ticks here?
335
  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
336
  decl_path <- getPathEntry
337
  let top_lev = null decl_path
338
  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
339

340 341 342 343
    -- Allocate the ticks
    rhs_tick <- bindTick density name pos fvs
    let patvars = map getOccString (collectPatBinders lhs)
    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
344

345 346 347 348 349 350
    -- Add to pattern
    let mbCons = maybe id (:)
        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
        patvar_tickss = zipWith mbCons patvar_ticks
                        (snd (pat_ticks pat') ++ repeat [])
    return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
andy@galois.com's avatar
andy@galois.com committed
351

352 353
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
cactus's avatar
cactus committed
354
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
andy@galois.com's avatar
andy@galois.com committed
355

356

357 358
bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
359 360 361 362 363 364 365 366 367 368 369 370
bindTick density name pos fvs = do
  decl_path <- getPathEntry
  let
      toplev        = null decl_path
      count_entries = toplev || density == TickAllFunctions
      top_only      = density /= TickAllFunctions
      box_label     = if toplev then TopLevelBox [name]
                                else LocalBox (decl_path ++ [name])
  --
  allocATickBox box_label count_entries top_only pos fvs


371 372 373 374 375 376 377 378 379 380 381 382 383 384
-- Note [inline sccs]
--
-- It should be reasonable to add ticks to INLINE functions; however
-- currently this tickles a bug later on because the SCCfinal pass
-- does not look inside unfoldings to find CostCentres.  It would be
-- difficult to fix that, because SCCfinal currently works on STG and
-- not Core (and since it also generates CostCentres for CAFs,
-- changing this would be difficult too).
--
-- Another reason not to add ticks to INLINE functions is that this
-- sometimes handy for avoiding adding a tick to a particular function
-- (see #6131)
--
-- So for now we do not add any ticks to INLINE functions at all.
385 386 387 388 389
--
-- We used to use isAnyInlinePragma to figure out whether to avoid adding
-- ticks for this purpose. However, #12962 indicates that this contradicts
-- the documentation on profiling (which only mentions INLINE pragmas).
-- So now we're more careful about what we avoid adding ticks to.
390

391 392 393 394
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
395
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
396
addTickLHsExpr e@(L pos e0) = do
397 398
  d <- getDensity
  case d of
399
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
400
    TickForCoverage    -> tick_it
401
    TickCallSites      | isCallSite e0      -> tick_it
402 403 404
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
405 406 407 408 409 410
   dont_tick_it = addTickLHsExprNever e

-- Add a tick to an expression which is the RHS of an equation or a binding.
-- We always consider these to be breakpoints, unless the expression is a 'let'
-- (because the body will definitely have a tick somewhere).  ToDo: perhaps
-- we should treat 'case' and 'if' the same way?
411
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
412
addTickLHsExprRHS e@(L pos e0) = do
413 414
  d <- getDensity
  case d of
415 416
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
417
     TickForCoverage -> tick_it
418
     TickCallSites   | isCallSite e0 -> tick_it
419 420 421
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
422 423 424 425 426 427
   dont_tick_it = addTickLHsExprNever e

-- The inner expression of an evaluation context:
--    let binds in [], ( [] )
-- we never tick these if we're doing HPC, but otherwise
-- we treat it like an ordinary expression.
428
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
429 430 431 432 433 434 435 436 437 438 439
addTickLHsExprEvalInner e = do
   d <- getDensity
   case d of
     TickForCoverage -> addTickLHsExprNever e
     _otherwise      -> addTickLHsExpr e

-- | A let body is treated differently from addTickLHsExprEvalInner
-- above with TickForBreakPoints, because for breakpoints we always
-- want to tick the body, even if it is not a redex.  See test
-- break012.  This gives the user the opportunity to inspect the
-- values of the let-bound variables.
440
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
441 442 443 444 445 446 447 448 449
addTickLHsExprLetBody e@(L pos e0) = do
  d <- getDensity
  case d of
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
     _other -> addTickLHsExprEvalInner e
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
   dont_tick_it = addTickLHsExprNever e
450

451
-- version of addTick that does not actually add a tick,
452
-- because the scope of this tick is completely subsumed by
453
-- another.
454
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
455 456 457 458
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

459 460
-- general heuristic: expressions which do not denote values are good
-- break points
461
isGoodBreakExpr :: HsExpr GhcTc -> Bool
462 463 464 465
isGoodBreakExpr (HsApp {})     = True
isGoodBreakExpr (HsAppType {}) = True
isGoodBreakExpr (OpApp {})     = True
isGoodBreakExpr _other         = False
466

467
isCallSite :: HsExpr GhcTc -> Bool
468 469 470
isCallSite HsApp{}     = True
isCallSite HsAppType{} = True
isCallSite OpApp{}     = True
471 472
isCallSite _ = False

473
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
474
addTickLHsExprOptAlt oneOfMany (L pos e0)
475 476 477
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
478

479
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
480 481 482 483 484 485 486
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
487 488 489
-- Decorate the body of an HsExpr with ticks.
-- (Whether to put a tick around the whole expression was already decided,
-- in the addTickLHsExpr family of functions.)
andy@galois.com's avatar
andy@galois.com committed
490

491
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
492 493 494
addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut _ con)
Richard Eisenberg's avatar
Richard Eisenberg committed
495
  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510
addTickHsExpr e@(HsIPVar {})       = return e
addTickHsExpr e@(HsOverLit {})     = return e
addTickHsExpr e@(HsOverLabel{})    = return e
addTickHsExpr e@(HsLit {})         = return e
addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
                                           (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
                                           (addTickMatchGroup True mgs)
addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
                                                      (addTickLHsExpr      e2)
addTickHsExpr (HsAppType ty e)   = liftM2 HsAppType (return ty)
                                                    (addTickLHsExprNever e)


addTickHsExpr (OpApp fix e1 e2 e3) =
511
        liftM4 OpApp
512
                (return fix)
513 514
                (addTickLHsExpr e1)
                (addTickLHsExprNever e2)
515
                (addTickLHsExpr e3)
516 517
addTickHsExpr (NegApp x e neg) =
        liftM2 (NegApp x)
518 519
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan neg)
520 521 522 523
addTickHsExpr (HsPar x e) =
        liftM (HsPar x) (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL x e1 e2) =
        liftM2 (SectionL x)
524
                (addTickLHsExpr e1)
525
                (addTickLHsExprNever e2)
526 527
addTickHsExpr (SectionR x e1 e2) =
        liftM2 (SectionR x)
528
                (addTickLHsExprNever e1)
529
                (addTickLHsExpr e2)
530 531
addTickHsExpr (ExplicitTuple x es boxity) =
        liftM2 (ExplicitTuple x)
532 533
                (mapM addTickTupArg es)
                (return boxity)
534
addTickHsExpr (ExplicitSum ty tag arity e) = do
535
        e' <- addTickLHsExpr e
536 537 538
        return (ExplicitSum ty tag arity e')
addTickHsExpr (HsCase x e mgs) =
        liftM2 (HsCase x)
539 540
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
541
                (addTickMatchGroup False mgs)
542 543
addTickHsExpr (HsIf x cnd e1 e2 e3) =
        liftM3 (HsIf x cnd)
544 545 546
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
547 548 549 550
addTickHsExpr (HsMultiIf ty alts)
  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
       ; return $ HsMultiIf ty alts' }
551
addTickHsExpr (HsLet x (L l binds) e) =
552
        bindLocals (collectLocalBinders binds) $
553
          liftM2 (HsLet x . L l)
554 555
                  (addTickHsLocalBinds binds) -- to think about: !patterns.
                  (addTickLHsExprLetBody e)
556
addTickHsExpr (HsDo srcloc cxt (L l stmts))
557
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
558
       ; return (HsDo srcloc cxt (L l stmts')) }
andy@galois.com's avatar
andy@galois.com committed
559
  where
560 561 562
        forQual = case cxt of
                    ListComp -> Just $ BinBox QualBinBox
                    _        -> Nothing
563 564
addTickHsExpr (ExplicitList ty wit es) =
        liftM3 ExplicitList
565
                (return ty)
566
                (addTickWit wit)
Austin Seipp's avatar
Austin Seipp committed
567
                (mapM (addTickLHsExpr) es)
568
             where addTickWit Nothing = return Nothing
569 570 571
                   addTickWit (Just fln)
                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
                          return (Just fln')
572
addTickHsExpr (ExplicitPArr ty es) =
573 574 575
        liftM2 ExplicitPArr
                (return ty)
                (mapM (addTickLHsExpr) es)
Facundo Domínguez's avatar
Facundo Domínguez committed
576

577
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
Facundo Domínguez's avatar
Facundo Domínguez committed
578

579 580 581 582 583 584 585 586
addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
  = do { rec_binds' <- addTickHsRecordBinds rec_binds
       ; return (expr { rcon_flds = rec_binds' }) }

addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
  = do { e' <- addTickLHsExpr e
       ; flds' <- mapM addTickHsRecField flds
       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
587

588
addTickHsExpr (ExprWithTySig ty e) =
589
        liftM2 ExprWithTySig
590
                (return ty)
591 592 593
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                        -- for expressions with signatures
addTickHsExpr (ArithSeq ty wit arith_seq) =
594
        liftM3 ArithSeq
595
                (return ty)
596
                (addTickWit wit)
597
                (addTickArithSeqInfo arith_seq)
598
             where addTickWit Nothing = return Nothing
599
                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
600
                                             return (Just fl')
601 602

-- We might encounter existing ticks (multiple Coverage passes)
603 604 605 606
addTickHsExpr (HsTick x t e) =
        liftM (HsTick x t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick x t0 t1 e) =
        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
607

608
addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
609
    e2 <- allocTickBox (ExpBox False) False False pos $
610
                addTickHsExpr e0
611
    return $ unLoc e2
612
addTickHsExpr (PArrSeq ty arith_seq) =
613 614 615
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
616 617
addTickHsExpr (HsSCC x src nm e) =
        liftM3 (HsSCC x)
Alan Zimmerman's avatar
Alan Zimmerman committed
618
                (return src)
619 620
                (return nm)
                (addTickLHsExpr e)
621 622
addTickHsExpr (HsCoreAnn x src nm e) =
        liftM3 (HsCoreAnn x)
Alan Zimmerman's avatar
Alan Zimmerman committed
623
                (return src)
624 625
                (return nm)
                (addTickLHsExpr e)
626 627 628 629
addTickHsExpr e@(HsBracket     {})   = return e
addTickHsExpr e@(HsTcBracketOut  {}) = return e
addTickHsExpr e@(HsRnBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {})      = return e
630 631
addTickHsExpr (HsProc x pat cmdtop) =
        liftM2 (HsProc x)
632 633
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
634 635
addTickHsExpr (HsWrap x w e) =
        liftM2 (HsWrap x)
636
                (return w)
637 638 639
                (addTickHsExpr e)       -- Explicitly no tick on inside

-- Others should never happen in expression content.
640
addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
andy@galois.com's avatar
andy@galois.com committed
641

642
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
643 644 645
addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
                                      ; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
646

647 648
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
649
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
650
  let isOneOfMany = matchesOneOfMany matches
651
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
652
  return $ mg { mg_alts = L l matches' }
andy@galois.com's avatar
andy@galois.com committed
653

654 655
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
             -> TM (Match GhcTc (LHsExpr GhcTc))
656
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats, m_grhss = gRHSs }) =
657
  bindLocals (collectPatsBinders pats) $ do
658
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
659
    return $ match { m_grhss = gRHSs' }
andy@galois.com's avatar
andy@galois.com committed
660

661 662
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
663
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
664
  bindLocals binders $ do
665
    local_binds' <- addTickHsLocalBinds local_binds
666
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
667
    return $ GRHSs guarded' (L l local_binds')
668
  where
669
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
670

671 672
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
            -> TM (GRHS GhcTc (LHsExpr GhcTc))
673
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
674
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
675
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
676 677
  return $ GRHS stmts' expr'

678
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
679 680 681 682 683 684 685 686 687
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
  d <- getDensity
  case d of
    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
    TickAllFunctions | isLambda ->
       addPathEntry "\\" $
         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
           addTickHsExpr e0
    _otherwise ->
688
       addTickLHsExprRHS expr
689

690 691
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
              -> TM [ExprLStmt GhcTc]
692
addTickLStmts isGuard stmts = do
693 694 695
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

696 697
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
698
addTickLStmts' isGuard lstmts res
699
  = bindLocals (collectLStmtsBinders lstmts) $
700 701 702
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
703

704 705
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
            -> TM (Stmt GhcTc (LHsExpr GhcTc))
Simon Marlow's avatar
Simon Marlow committed
706 707
addTickStmt _isGuard (LastStmt e noret ret) = do
        liftM3 LastStmt
708
                (addTickLHsExpr e)
Simon Marlow's avatar
Simon Marlow committed
709
                (pure noret)
710
                (addTickSyntaxExpr hpcSrcSpan ret)
711 712
addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
        liftM5 BindStmt
713 714 715 716
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
717
                (return ty)
718 719
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
        liftM4 BodyStmt
720 721 722 723
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
                (return ty)
724 725
addTickStmt _isGuard (LetStmt (L l binds)) = do
        liftM (LetStmt . L l)
726
                (addTickHsLocalBinds binds)
727 728
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
    liftM4 ParStmt
729
        (mapM (addTickStmtAndBinders isGuard) pairs)
730
        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
731
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
732
        (return ty)
Simon Marlow's avatar
Simon Marlow committed
733 734 735
addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
    args' <- mapM (addTickApplicativeArg isGuard) args
    return (ApplicativeStmt args' mb_join body_ty)
736

737 738 739 740
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
741
    t_s <- addTickLStmts isGuard stmts
742 743
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
744 745
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
746
    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
747 748
    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
749

750 751 752 753 754 755
addTickStmt isGuard stmt@(RecStmt {})
  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
756
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
757

758
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
759
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
760
                  | otherwise          = addTickLHsExprRHS e
761

Simon Marlow's avatar
Simon Marlow committed
762
addTickApplicativeArg
763 764
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
Simon Marlow's avatar
Simon Marlow committed
765 766 767
addTickApplicativeArg isGuard (op, arg) =
  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
 where
768 769 770 771 772
  addTickArg (ApplicativeArgOne pat expr isBody) =
    ApplicativeArgOne
      <$> addTickLPat pat
      <*> addTickLHsExpr expr
      <*> pure isBody
Simon Marlow's avatar
Simon Marlow committed
773 774 775
  addTickArg (ApplicativeArgMany stmts ret pat) =
    ApplicativeArgMany
      <$> addTickLStmts isGuard stmts
776
      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
Simon Marlow's avatar
Simon Marlow committed
777 778
      <*> addTickLPat pat

779 780
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
781 782
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
783 784
        (addTickLStmts isGuard stmts)
        (return ids)
785
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
786

787
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
788 789 790 791 792 793
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
794 795
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

796 797 798 799
addTickHsValBinds :: HsValBindsLR