Coverage.hs 52 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
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
9
{-# LANGUAGE DeriveFunctor #-}
10

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

13 14
import GhcPrelude as Prelude

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

47 48
import Data.Time
import System.Directory
49

50 51 52
import Trace.Hpc.Mix
import Trace.Hpc.Util

53
import qualified Data.ByteString as BS
54 55
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
56

Austin Seipp's avatar
Austin Seipp committed
57 58 59 60 61 62 63
{-
************************************************************************
*                                                                      *
*              The main function: addTicksToBinds
*                                                                      *
************************************************************************
-}
64

65
addTicksToBinds
66
        :: HscEnv
67
        -> Module
68 69 70 71 72
        -> 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
73 74
        -> LHsBinds GhcTc
        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
75

76 77 78
addTicksToBinds hsc_env mod mod_loc exports tyCons binds
  | let dflags = hsc_dflags hsc_env
        passes = coveragePasses dflags, not (null passes),
79 80
    Just orig_file <- ml_hs_file mod_loc,
    not ("boot" `isSuffixOf` orig_file) = do
81

82
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
83

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

          initState = TT { tickBoxCount = 0
                         , mixEntries   = []
104
                         , ccIndices    = newCostCentreState
105 106 107 108 109
                         }

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

     let tickCount = tickBoxCount st
110 111 112
         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
113

114
     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
115

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

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

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


133 134 135
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks hsc_env mod count entries
  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
136
    breakArray <- GHCi.newBreakArray hsc_env (length entries)
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
    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_]
153
  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
154
mkCCSArray hsc_env modul count entries = do
155
  if interpreterProfiled dflags
156
    then do
157 158
      let module_str = moduleNameString (moduleName modul)
      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
159 160 161 162
      return (listArray (0,count-1) costcentres)
    else do
      return (listArray (0,-1) [])
 where
163 164 165 166
    dflags = hsc_dflags hsc_env
    mk_one (srcspan, decl_path, _, _) = (name, src)
      where name = concat (intersperse "." decl_path)
            src = showSDoc dflags (ppr srcspan)
167 168 169 170


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

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

182 183
            tabStop = 8 -- <tab> counts as a normal char in GHC's
                        -- 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 191
          panic "the number of .mix entries are inconsistent"
        let hashNo = mixHash filename modTime tabStop entries'
192
        mixCreate hpc_mod_dir mod_name
193 194 195 196 197 198 199 200 201 202 203 204 205
                       $ 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
206
  | TickCallSites         -- for stack tracing
207 208
  deriving Eq

209 210 211 212 213 214 215 216 217 218 219 220
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"
221 222 223 224 225 226 227 228 229

-- | 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

230
shouldTickBind density top_lev exported _simple_pat inline
231
 = case density of
232
      TickForBreakPoints    -> False
233 234 235 236 237 238
        -- 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
239
      TickCallSites         -> False
240 241 242 243 244 245 246 247 248

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

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

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

257
addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
258
addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds   = binds,
259 260
                                       abs_exports = abs_exports })) = do
  withEnv add_exports $ do
261
  withEnv add_inlines $ do
262
  binds' <- addTickLHsBinds binds
263
  return $ cL pos $ bind { abs_binds = binds' }
264 265 266 267 268 269 270
 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 =
271
     env{ exports = exports env `extendNameSetList`
272 273 274 275
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

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

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

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

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

297
  (fvs, mg) <-
298
        getFreeVars $
299
        addPathEntry name $
300
        addTickMatchGroup False (fun_matches funBind)
301

302 303 304 305
  case mg of
    MG {} -> return ()
    _     -> panic "addTickLHsBind"

306
  blackListed <- isBlackListed pos
307
  exported_names <- liftM exports getEnv
308 309

  -- We don't want to generate code for blacklisted positions
310 311 312 313 314 315 316 317 318 319 320 321 322
  -- 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

323
  let mbCons = maybe Prelude.id (:)
324 325
  return $ cL pos $ funBind { fun_matches = mg
                            , fun_tick = tick `mbCons` fun_tick funBind }
326

327
   where
328 329
   -- a binding is a simple pattern binding if it is a funbind with
   -- zero patterns
330
   isSimplePatBind :: HsBind GhcTc -> Bool
331
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
332 333

-- TODO: Revisit this
334 335
addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
                                        , pat_rhs = rhs }))) = do
andy@galois.com's avatar
andy@galois.com committed
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
andy@galois.com's avatar
andy@galois.com committed
342
  decl_path <- getPathEntry
343
  let top_lev = null decl_path
344 345 346
  if not (shouldTickPatBind density top_lev)
    then return (cL pos pat')
    else do
347

348 349 350 351
    -- 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
352

353 354 355 356 357
    -- 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 [])
358
    return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
andy@galois.com's avatar
andy@galois.com committed
359

360
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
361 362 363 364 365
addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
addTickLHsBind _  = panic "addTickLHsBind: Impossible Match" -- due to #15884

andy@galois.com's avatar
andy@galois.com committed
366

367

368 369
bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
370 371 372 373 374 375 376 377 378 379 380 381
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


382 383
-- Note [inline sccs]
--
384
-- The reason not to add ticks to INLINE functions is that this is
385 386 387 388
-- 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.
389 390 391 392 393
--
-- 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.
394

395 396 397 398
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
399
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
400
addTickLHsExpr e@(dL->L pos e0) = do
401 402
  d <- getDensity
  case d of
403
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
404
    TickForCoverage    -> tick_it
405
    TickCallSites      | isCallSite e0      -> tick_it
406 407 408
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
409 410 411 412 413 414
   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?
415
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
416
addTickLHsExprRHS e@(dL->L pos e0) = do
417 418
  d <- getDensity
  case d of
419 420
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
421
     TickForCoverage -> tick_it
422
     TickCallSites   | isCallSite e0 -> tick_it
423 424 425
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
426 427 428 429 430 431
   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.
432
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
433 434 435 436 437 438 439 440 441 442 443
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.
444
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
445
addTickLHsExprLetBody e@(dL->L pos e0) = do
446 447 448 449 450 451 452 453
  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
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.
458
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
459
addTickLHsExprNever (dL->L pos e0) = do
460
    e1 <- addTickHsExpr e0
461
    return $ cL pos e1
462

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

471
isCallSite :: HsExpr GhcTc -> Bool
472 473 474
isCallSite HsApp{}     = True
isCallSite HsAppType{} = True
isCallSite OpApp{}     = True
475 476
isCallSite _ = False

477
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
478
addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
479 480
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
481
        (addTickLHsExpr (cL pos e0))
andy@galois.com's avatar
andy@galois.com committed
482

483
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
484
addBinTickLHsExpr boxLabel (dL->L pos e0)
485 486
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
487
        (addTickLHsExpr (cL pos e0))
488 489 490


-- -----------------------------------------------------------------------------
491 492 493
-- 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
494

495
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
496
addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e
497 498
addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut _ con)
Richard Eisenberg's avatar
Richard Eisenberg committed
499
  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
500 501 502 503 504 505 506 507 508 509
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)
510 511 512
addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
                                                      (addTickLHsExprNever e)
                                                      (return ty)
513 514

addTickHsExpr (OpApp fix e1 e2 e3) =
515
        liftM4 OpApp
516
                (return fix)
517 518
                (addTickLHsExpr e1)
                (addTickLHsExprNever e2)
519
                (addTickLHsExpr e3)
520 521
addTickHsExpr (NegApp x e neg) =
        liftM2 (NegApp x)
522 523
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan neg)
524 525 526 527
addTickHsExpr (HsPar x e) =
        liftM (HsPar x) (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL x e1 e2) =
        liftM2 (SectionL x)
528
                (addTickLHsExpr e1)
529
                (addTickLHsExprNever e2)
530 531
addTickHsExpr (SectionR x e1 e2) =
        liftM2 (SectionR x)
532
                (addTickLHsExprNever e1)
533
                (addTickLHsExpr e2)
534 535
addTickHsExpr (ExplicitTuple x es boxity) =
        liftM2 (ExplicitTuple x)
536 537
                (mapM addTickTupArg es)
                (return boxity)
538
addTickHsExpr (ExplicitSum ty tag arity e) = do
539
        e' <- addTickLHsExpr e
540 541 542
        return (ExplicitSum ty tag arity e')
addTickHsExpr (HsCase x e mgs) =
        liftM2 (HsCase x)
543 544
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
545
                (addTickMatchGroup False mgs)
546 547
addTickHsExpr (HsIf x cnd e1 e2 e3) =
        liftM3 (HsIf x cnd)
548 549 550
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
551 552 553 554
addTickHsExpr (HsMultiIf ty alts)
  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
       ; return $ HsMultiIf ty alts' }
555
addTickHsExpr (HsLet x (dL->L l binds) e) =
556
        bindLocals (collectLocalBinders binds) $
557
          liftM2 (HsLet x . cL l)
558 559
                  (addTickHsLocalBinds binds) -- to think about: !patterns.
                  (addTickLHsExprLetBody e)
560
addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
561
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
562
       ; return (HsDo srcloc cxt (cL l stmts')) }
andy@galois.com's avatar
andy@galois.com committed
563
  where
564 565 566
        forQual = case cxt of
                    ListComp -> Just $ BinBox QualBinBox
                    _        -> Nothing
567 568
addTickHsExpr (ExplicitList ty wit es) =
        liftM3 ExplicitList
569
                (return ty)
570
                (addTickWit wit)
Austin Seipp's avatar
Austin Seipp committed
571
                (mapM (addTickLHsExpr) es)
572
             where addTickWit Nothing = return Nothing
573 574 575
                   addTickWit (Just fln)
                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
                          return (Just fln')
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 589 590
addTickHsExpr (ExprWithTySig x e ty) =
        liftM3 ExprWithTySig
                (return x)
591 592
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                        -- for expressions with signatures
593
                (return ty)
594
addTickHsExpr (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)
604 605 606 607
addTickHsExpr (HsTick x t e) =
        liftM (HsTick x t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick x t0 t1 e) =
        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
608

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

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

639
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
640 641 642
addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e
                                            ; return (cL l (Present x e')) }
addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
643
addTickTupArg (dL->L _ (XTupArg nec)) = noExtCon nec
644 645
addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884

646

647 648
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
649
addTickMatchGroup 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' }
653
addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
654

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

664 665
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
666
addTickGRHSs 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
673
addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
674

675 676
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
            -> TM (GRHS GhcTc (LHsExpr GhcTc))
677
addTickGRHS 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'
681
addTickGRHS _ _ (XGRHS nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
682

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

695 696
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
              -> TM [ExprLStmt GhcTc]
697
addTickLStmts isGuard stmts = do
698 699 700
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

701 702
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
703
addTickLStmts' isGuard lstmts res
704
  = bindLocals (collectLStmtsBinders lstmts) $
705 706 707
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
708

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

739 740 741 742
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
743
    t_s <- addTickLStmts isGuard stmts
744 745
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
746 747
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
748
    t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))
749 750
    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 }
751

752 753 754 755 756 757
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'
758
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
759

760
addTickStmt _ (XStmtLR nec) = noExtCon nec
761

762
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
763
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
764
                  | otherwise          = addTickLHsExprRHS e
765

Simon Marlow's avatar
Simon Marlow committed
766
addTickApplicativeArg
767 768
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
Simon Marlow's avatar
Simon Marlow committed
769 770 771
addTickApplicativeArg isGuard (op, arg) =
  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
 where
772 773
  addTickArg (ApplicativeArgOne x pat expr isBody) =
    (ApplicativeArgOne x)
774 775 776
      <$> addTickLPat pat
      <*> addTickLHsExpr expr
      <*> pure isBody
777 778
  addTickArg (ApplicativeArgMany x stmts ret pat) =
    (ApplicativeArgMany x)
Simon Marlow's avatar
Simon Marlow committed
779
      <$> addTickLStmts isGuard stmts
780
      <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
Simon Marlow's avatar
Simon Marlow committed
781
      <*> addTickLPat pat
782
  addTickArg (XApplicativeArg nec) = noExtCon nec
Simon Marlow's avatar
Simon Marlow committed
783

784 785
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
786