Coverage.hs 50.6 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
Gergő Érdi's avatar
Gergő Érdi 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
-- Note [inline sccs]
--
373
-- The reason not to add ticks to INLINE functions is that this is
374 375 376 377
-- 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.
378 379 380 381 382
--
-- 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.
383

384 385 386 387
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
388
addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
389
addTickLHsExpr e@(L pos e0) = do
390 391
  d <- getDensity
  case d of
392
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
393
    TickForCoverage    -> tick_it
394
    TickCallSites      | isCallSite e0      -> tick_it
395 396 397
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
398 399 400 401 402 403
   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?
404
addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
405
addTickLHsExprRHS e@(L pos e0) = do
406 407
  d <- getDensity
  case d of
408 409
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
410
     TickForCoverage -> tick_it
411
     TickCallSites   | isCallSite e0 -> tick_it
412 413 414
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
415 416 417 418 419 420
   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.
421
addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
422 423 424 425 426 427 428 429 430 431 432
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.
433
addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
434 435 436 437 438 439 440 441 442
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
443

444
-- version of addTick that does not actually add a tick,
445
-- because the scope of this tick is completely subsumed by
446
-- another.
447
addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
448 449 450 451
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

452 453
-- general heuristic: expressions which do not denote values are good
-- break points
454
isGoodBreakExpr :: HsExpr GhcTc -> Bool
Ben Gamari's avatar
Ben Gamari committed
455 456 457 458
isGoodBreakExpr (HsApp {})        = True
isGoodBreakExpr (HsAppTypeOut {}) = True
isGoodBreakExpr (OpApp {})        = True
isGoodBreakExpr _other            = False
459

460
isCallSite :: HsExpr GhcTc -> Bool
Ben Gamari's avatar
Ben Gamari committed
461 462 463
isCallSite HsApp{}        = True
isCallSite HsAppTypeOut{} = True
isCallSite OpApp{}        = True
464 465
isCallSite _ = False

466
addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
467
addTickLHsExprOptAlt oneOfMany (L pos e0)
468 469 470
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
471

472
addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
473 474 475 476 477 478 479
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
480 481 482
-- 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
483

484
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
Ben Gamari's avatar
Ben Gamari committed
485 486 487
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
488
  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
Ben Gamari's avatar
Ben Gamari committed
489 490 491 492 493 494 495 496 497 498 499 500
addTickHsExpr e@(HsIPVar _)      = return e
addTickHsExpr e@(HsOverLit _)    = return e
addTickHsExpr e@(HsOverLabel{})  = return e
addTickHsExpr e@(HsLit _)        = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
                                                (addTickLHsExpr      e2)
addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
                                                        (return ty)

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

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

569 570 571 572 573 574 575 576
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' }) }
577

Ben Gamari's avatar
Ben Gamari committed
578
addTickHsExpr (ExprWithTySig e ty) =
579
        liftM2 ExprWithTySig
580
                (addTickLHsExprNever e) -- No need to tick the inner expression
Ben Gamari's avatar
Ben Gamari committed
581 582 583
                                    -- for expressions with signatures
                (return ty)
addTickHsExpr (ArithSeq  ty wit arith_seq) =
584
        liftM3 ArithSeq
585
                (return ty)
586
                (addTickWit wit)
587
                (addTickArithSeqInfo arith_seq)
588
             where addTickWit Nothing = return Nothing
589
                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
590
                                             return (Just fl')
591 592

-- We might encounter existing ticks (multiple Coverage passes)
Ben Gamari's avatar
Ben Gamari committed
593 594 595 596
addTickHsExpr (HsTick t e) =
        liftM (HsTick t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick t0 t1 e) =
        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)
597

Ben Gamari's avatar
Ben Gamari committed
598
addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
599
    e2 <- allocTickBox (ExpBox False) False False pos $
600
                addTickHsExpr e0
601
    return $ unLoc e2
Ben Gamari's avatar
Ben Gamari committed
602
addTickHsExpr (PArrSeq   ty arith_seq) =
603 604 605
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
Ben Gamari's avatar
Ben Gamari committed
606 607
addTickHsExpr (HsSCC src nm e) =
        liftM3 HsSCC
Alan Zimmerman's avatar
Alan Zimmerman committed
608
                (return src)
609 610
                (return nm)
                (addTickLHsExpr e)
Ben Gamari's avatar
Ben Gamari committed
611 612
addTickHsExpr (HsCoreAnn src nm e) =
        liftM3 HsCoreAnn
Alan Zimmerman's avatar
Alan Zimmerman committed
613
                (return src)
614 615
                (return nm)
                (addTickLHsExpr e)
616 617 618 619
addTickHsExpr e@(HsBracket     {})   = return e
addTickHsExpr e@(HsTcBracketOut  {}) = return e
addTickHsExpr e@(HsRnBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {})      = return e
Ben Gamari's avatar
Ben Gamari committed
620 621
addTickHsExpr (HsProc pat cmdtop) =
        liftM2 HsProc
622 623
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
Ben Gamari's avatar
Ben Gamari committed
624 625
addTickHsExpr (HsWrap w e) =
        liftM2 HsWrap
626
                (return w)
627 628
                (addTickHsExpr e)       -- Explicitly no tick on inside

Ben Gamari's avatar
Ben Gamari committed
629 630 631 632 633
addTickHsExpr (ExprWithTySigOut e ty) =
        liftM2 ExprWithTySigOut
               (addTickLHsExprNever e) -- No need to tick the inner expression
               (return ty)             -- for expressions with signatures

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

637
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
Ben Gamari's avatar
Ben Gamari committed
638 639
addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
                                      ; return (L l (Present e')) }
640
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
641

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

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

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

666 667
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
            -> TM (GRHS GhcTc (LHsExpr GhcTc))
668
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
669
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
670
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
671 672
  return $ GRHS stmts' expr'

673
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
674 675 676 677 678 679 680 681 682
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 ->
683
       addTickLHsExprRHS expr
684

685 686
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
              -> TM [ExprLStmt GhcTc]
687
addTickLStmts isGuard stmts = do
688 689 690
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

691 692
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
               -> TM ([ExprLStmt GhcTc], a)
693
addTickLStmts' isGuard lstmts res
694
  = bindLocals (collectLStmtsBinders lstmts) $
695 696 697
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
698

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

732 733 734 735
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
736
    t_s <- addTickLStmts isGuard stmts
737 738
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
739 740
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
741
    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
742 743
    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 }
744

745 746 747 748 749 750
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'
751
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
752

753
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
754
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
755
                  | otherwise          = addTickLHsExprRHS e
756

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

774 775
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
Ben Gamari's avatar
Ben Gamari committed
776 777
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
778 779
        (addTickLStmts isGuard stmts)
        (return ids)
780
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
781

782
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
783 784 785 786 787 788
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
789 790
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

Ben Gamari's avatar