Coverage.hs 51.4 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
21
import GHC.Hs
andy@galois.com's avatar
andy@galois.com committed
22 23
import Module
import Outputable
24
import DynFlags
25
import ConLike
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

Sylvain Henry's avatar
Sylvain Henry committed
114 115
     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell
       (pprLHsBinds binds1)
116

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

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

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


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


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

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

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

        createDirectoryIfMissing True hpc_mod_dir
187
        modTime <- getModificationUTCTime filename
188
        let entries' = [ (hpcPos, box)
189
                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
190
        when (entries' `lengthIsNot` count) $ do
191 192
          panic "the number of .mix entries are inconsistent"
        let hashNo = mixHash filename modTime tabStop entries'
193
        mixCreate hpc_mod_dir mod_name
194 195 196 197 198 199 200 201 202 203 204 205 206
                       $ 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
207
  | TickCallSites         -- for stack tracing
208 209
  deriving Eq

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- TODO: Revisit this
335 336
addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
                                    , pat_rhs = rhs }))) = do
andy@galois.com's avatar
andy@galois.com committed
337
  let name = "(...)"
338
  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
339
  let pat' = pat { pat_rhs = rhs'}
340

341
  -- Should create ticks here?
342
  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
343
  decl_path <- getPathEntry
344
  let top_lev = null decl_path
345
  if not (shouldTickPatBind density top_lev)
346
    then return (L pos pat')
347
    else do
348

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

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

361
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
362 363 364
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
andy@galois.com's avatar
andy@galois.com committed
365

366

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


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

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

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

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

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

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

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

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


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

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

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

576
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
577

578 579 580 581 582 583 584 585
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' }) }
586

587 588 589
addTickHsExpr (ExprWithTySig x e ty) =
        liftM3 ExprWithTySig
                (return x)
590 591
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                        -- for expressions with signatures
592
                (return ty)
593
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 (HsPragE _ HsPragTick{} (L pos e0)) = do
609
    e2 <- allocTickBox (ExpBox False) False False pos $
610
                addTickHsExpr e0
611
    return $ unLoc e2
612 613
addTickHsExpr (HsPragE x p e) =
        liftM (HsPragE x p) (addTickLHsExpr e)
614 615 616 617
addTickHsExpr e@(HsBracket     {})   = return e
addTickHsExpr e@(HsTcBracketOut  {}) = return e
addTickHsExpr e@(HsRnBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {})      = return e
618 619
addTickHsExpr (HsProc x pat cmdtop) =
        liftM2 (HsProc x)
620 621
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
622 623
addTickHsExpr (HsWrap x w e) =
        liftM2 (HsWrap x)
624
                (return w)
625 626 627
                (addTickHsExpr e)       -- Explicitly no tick on inside

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

630
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
631 632 633 634
addTickTupArg (L l (Present x e))  = do { e' <- addTickLHsExpr e
                                        ; return (L l (Present x e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
635

636

637 638
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
639
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
640
  let isOneOfMany = matchesOneOfMany matches
641
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
642
  return $ mg { mg_alts = L l matches' }
643
addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
644

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

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

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

673
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
674
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
675 676 677 678 679 680 681 682
  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))
701 702
addTickStmt _isGuard (LastStmt x e noret ret) = do
        liftM3 (LastStmt x)
703
                (addTickLHsExpr e)
Simon Marlow's avatar
Simon Marlow committed
704
                (pure noret)
705
                (addTickSyntaxExpr hpcSrcSpan ret)
706 707
addTickStmt _isGuard (BindStmt x pat e bind fail) = do
        liftM4 (BindStmt x)
708 709 710 711
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
712 713
addTickStmt isGuard (BodyStmt x e bind' guard') = do
        liftM3 (BodyStmt x)
714 715 716
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
717 718
addTickStmt _isGuard (LetStmt x (L l binds)) = do
        liftM (LetStmt x . L l)
719
                (addTickHsLocalBinds binds)
720 721
addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
    liftM3 (ParStmt x)
722
        (mapM (addTickStmtAndBinders isGuard) pairs)
723
        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
724
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
725
addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
Simon Marlow's avatar
Simon Marlow committed
726
    args' <- mapM (addTickApplicativeArg isGuard) args
727
    return (ApplicativeStmt body_ty args' mb_join)
728

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

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

750
addTickStmt _ (XStmtLR nec) = noExtCon nec
751

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

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

775 776
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
                      -> TM (ParStmtBlock GhcTc GhcTc)
777 778
addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
    liftM3 (ParStmtBlock x)
779 780
        (addTickLStmts isGuard stmts)
        (return ids)
781
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
782
addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
783

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

794 795 796 797
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
                  -> TM (HsValBindsLR GhcTc (GhcPass b))
addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
        b <- liftM2 NValBinds
798 799 800 801 802 803
                (mapM (\ (rec,binds') ->
                                liftM2 (,)
                                        (return rec)
                                        (addTickLHsBinds binds'))
                        binds)
                (return sigs)
804
        return $ XValBindsLR b
805
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
806

807
addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
808
addTickHsIPBinds (IPBinds dictbinds ipbinds) =
809 810
        liftM2 IPBinds
                (return dictbinds)
811 812
                (mapM (liftL (addTickIPBind)) ipbinds)
addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
andy@galois.com's avatar
andy@galois.com committed
813

814
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
815 816
addTickIPBind (IPBind x nm e) =
        liftM2 (IPBind x)
817 818
                (return nm)
                (addTickLHsExpr e)
819
addTickIPBind (XIPBind x) = return (XIPBind x)
andy@galois.com's avatar
andy@galois.com committed
820 821

-- There is no location here, so we might need to use a context location??
822
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
823
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
824
        x' <- fmap unLoc (addTickLHsExpr (L pos x))
825
        return $ syn { syn_expr = x' }
andy@galois.com's avatar
andy@galois.com committed
826
-- we do not walk into patterns.
827
addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
andy@galois.com's avatar
andy@galois.com committed
828 829
addTickLPat pat = return pat

830
addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
831 832 833
addTickHsCmdTop (HsCmdTop x cmd) =
        liftM2 HsCmdTop
                (return x)
834
                (addTickLHsCmd cmd)
835
addTickHsCmdTop (XCmdTop nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
836

837
addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
838
addTickLHsCmd (L pos c0) = do
839
        c1 <- addTickHsCmd c0
840
        return $ L pos c1
841

842
addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
843 844 845 846
addTickHsCmd (HsCmdLam x matchgroup) =
        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp x c e) =
        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
847
{-
848 849 850 851 852 853
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
854
-}
855 856 857
addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
addTickHsCmd (HsCmdCase x e mgs) =
        liftM2 (HsCmdCase x)
858 859
                (addTickLHsExpr e)
                (addTickCmdMatchGroup mgs)
860 861
addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
        liftM3 (HsCmdIf x cnd)
862 863 864
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsCmd c2)
                (addTickLHsCmd c3)
865
addTickHsCmd (HsCmdLet x (L l binds) c) =
866
        bindLocals (collectLocalBinders binds) $
867
          liftM2 (HsCmdLet x . L l)
868 869
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsCmd c)
870
addTickHsCmd (HsCmdDo srcloc (L l stmts))
871
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
872
       ; return (HsCmdDo srcloc (L l stmts')) }
873

874
addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
875
        liftM5 HsCmdArrApp
876
               (return arr_ty)
877 878 879 880
               (addTickLHsExpr e1)
               (addTickLHsExpr e2)
               (return ty1)
               (return lr)
881 882
addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
        liftM4 (HsCmdArrForm x)
883
               (addTickLHsExpr e)
884
               (return f)
885 886
               (return fix)
               (mapM (liftL (addTickHsCmdTop)) cmdtop)
887