Coverage.hs 51.5 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 12
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

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

15 16
import GhcPrelude as Prelude

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

49 50
import Data.Time
import System.Directory
51

52 53 54
import Trace.Hpc.Mix
import Trace.Hpc.Util

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

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

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

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

84
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
85

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

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

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

     let tickCount = tickBoxCount st
112 113 114
         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
115

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

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

121
  | otherwise = return (binds, emptyHpcInfo False, Nothing)
122

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


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


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

            hpc_mod_dir
182 183
              | moduleUnitId mod == mainUnitId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
184

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

309
  blackListed <- isBlackListed pos
310
  exported_names <- liftM exports getEnv
311 312

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

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

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

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

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

351 352 353 354
    -- 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
355

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

363
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
364 365 366
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
367

368

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


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

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

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

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

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

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

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

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


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

496
addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
497
addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e
498 499
addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsConLikeOut _ con)
500
  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
501 502 503 504 505 506 507 508 509 510
addTickHsExpr e@(HsIPVar {})       = return e
addTickHsExpr e@(HsOverLit {})     = return e
addTickHsExpr e@(HsOverLabel{})    = return e
addTickHsExpr e@(HsLit {})         = return e
addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
                                           (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
                                           (addTickMatchGroup True mgs)
addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
                                                      (addTickLHsExpr      e2)
511 512 513
addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
                                                      (addTickLHsExprNever e)
                                                      (return ty)
514 515

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

578
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
579

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

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

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

610
addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do
611
    e2 <- allocTickBox (ExpBox False) False False pos $
612
                addTickHsExpr e0
613
    return $ unLoc e2
614 615
addTickHsExpr (HsPragE x p e) =
        liftM (HsPragE x p) (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
620 621
addTickHsExpr (HsProc x pat cmdtop) =
        liftM2 (HsProc x)
622 623
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
624 625
addTickHsExpr (HsWrap x w e) =
        liftM2 (HsWrap x)
626
                (return w)
627 628 629
                (addTickHsExpr e)       -- Explicitly no tick on inside

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

632
addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
633 634 635 636
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
637

638

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

647 648
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
             -> TM (Match GhcTc (LHsExpr GhcTc))
649 650
addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
                                               , m_grhss = gRHSs }) =
651
  bindLocals (collectPatsBinders pats) $ do
652
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
653
    return $ match { m_grhss = gRHSs' }
654
addTickMatch _ _ (XMatch nec) = noExtCon nec
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 x 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 x guarded' (L l local_binds')
663
  where
664
    binders = collectLocalBinders local_binds
665
addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
andy@galois.com's avatar
andy@galois.com committed
666

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

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

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

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

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

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

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

752
addTickStmt _ (XStmtLR nec) = noExtCon nec
753

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

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

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

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

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

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

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

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

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

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

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