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

6
{-# LANGUAGE CPP, NondecreasingIndentation, RecordWildCards #-}
7

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

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

45 46
import Data.Time
import System.Directory
47

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

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

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

62
addTicksToBinds
63
        :: HscEnv
64
        -> Module
65 66 67 68 69
        -> 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
70
        -> LHsBinds Id
71
        -> IO (LHsBinds Id, HpcInfo, Maybe ModBreaks)
72

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

78
     if "boot" `isSuffixOf` orig_file
79
         then return (binds, emptyHpcInfo False, Nothing)
80
         else do
81

82
     us <- mkSplitUniqSupply 'C' -- for cost centres
83
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
84

85 86
          tickPass tickish (binds,st) =
            let env = TTE
87
                      { fileName     = mkFastString orig_file2
88
                      , declPath     = []
89
                      , tte_dflags   = dflags
90
                      , exports      = exports
91
                      , inlines      = emptyVarSet
92
                      , inScope      = emptyVarSet
93 94 95
                      , blackList    = Map.fromList
                                          [ (getSrcSpan (tyConName tyCon),())
                                          | tyCon <- tyCons ]
96
                      , density      = mkDensity tickish dflags
97
                      , this_mod     = mod
98
                      , tickishType  = tickish
99
}
100 101 102 103 104 105 106 107 108 109 110
                (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
111 112 113
         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
114

115
     when (dopt Opt_D_dump_ticked dflags) $
Ian Lynagh's avatar
Ian Lynagh committed
116
         log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
117
             (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 124 125 126

guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
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 $ foldrBag (\ (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
mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
137 138 139
#ifndef GHCI
mkModBreaks _hsc_env _mod _count _entries = return emptyModBreaks
#else
140 141
mkModBreaks hsc_env mod count entries
  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
142
    breakArray <- GHCi.newBreakArray hsc_env (length entries)
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
    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_]
159
  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
160 161 162 163
mkCCSArray hsc_env modul count entries = do
  if interpreterProfiled (hsc_dflags hsc_env)
    then do
      let module_bs = fastStringToByteString (moduleNameFS (moduleName modul))
164 165 166 167
      c_module <- GHCi.mallocData hsc_env (module_bs `B.snoc` 0)
        -- NB. null-terminate the string
      costcentres <-
        mapM (mkCostCentre hsc_env (castRemotePtr c_module)) entries
168 169 170 171 172 173
      return (listArray (0,count-1) costcentres)
    else do
      return (listArray (0,-1) [])
 where
    mkCostCentre
     :: HscEnv
174
     -> RemotePtr CChar
175
     -> MixEntry_
176
     -> IO (RemotePtr GHC.Stack.CCS.CostCentre)
177 178 179 180 181 182 183 184 185
    mkCostCentre hsc_env@HscEnv{..}  c_module (srcspan, decl_path, _, _) = do
      let name = concat (intersperse "." decl_path)
          src = showSDoc hsc_dflags (ppr srcspan)
      GHCi.mkCostCentre hsc_env c_module name src
#endif


writeMixEntries
  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
186
writeMixEntries dflags mod count entries filename
ian@well-typed.com's avatar
ian@well-typed.com committed
187
  | not (gopt Opt_Hpc dflags) = return 0
188 189 190 191 192 193
  | otherwise   = do
        let
            hpc_dir = hpcDir dflags
            mod_name = moduleNameString (moduleName mod)

            hpc_mod_dir
194 195
              | moduleUnitId mod == mainUnitId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
196

197 198
            tabStop = 8 -- <tab> counts as a normal char in GHC's
                        -- location ranges.
199 200

        createDirectoryIfMissing True hpc_mod_dir
201
        modTime <- getModificationUTCTime filename
202
        let entries' = [ (hpcPos, box)
203 204 205 206
                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
        when (length entries' /= count) $ do
          panic "the number of .mix entries are inconsistent"
        let hashNo = mixHash filename modTime tabStop entries'
207
        mixCreate hpc_mod_dir mod_name
208 209 210 211 212 213 214 215 216 217 218 219 220
                       $ 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
221
  | TickCallSites         -- for stack tracing
222 223
  deriving Eq

224 225 226 227 228 229 230 231 232 233 234 235
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"
236 237 238 239 240 241 242 243 244

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

245
shouldTickBind density top_lev exported _simple_pat inline
246
 = case density of
247
      TickForBreakPoints    -> False
248 249 250 251 252 253
        -- 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
254
      TickCallSites         -> False
255 256 257 258 259 260 261 262 263

shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind density top_lev
  = case density of
      TickForBreakPoints    -> False
      TickAllFunctions      -> True
      TickTopFunctions      -> top_lev
      TickExportedFunctions -> False
      TickForCoverage       -> False
264
      TickCallSites         -> False
265 266 267

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

addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
270
addTickLHsBinds = mapBagM addTickLHsBind
andy@galois.com's avatar
andy@galois.com committed
271 272

addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
273 274 275
addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                                       abs_exports = abs_exports })) = do
  withEnv add_exports $ do
276
  withEnv add_inlines $ do
277 278
  binds' <- addTickLHsBinds binds
  return $ L pos $ bind { abs_binds = binds' }
279 280 281 282 283 284 285
 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 =
286
     env{ exports = exports env `extendNameSetList`
287 288 289 290
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

291 292 293 294 295 296
   add_inlines env =
     env{ inlines = inlines env `extendVarSetList`
                      [ mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , isAnyInlinePragma (idInlinePragma pid) ] }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319
addTickLHsBind (L pos bind@(AbsBindsSig { abs_sig_bind   = val_bind
                                        , abs_sig_export = poly_id }))
  | L _ FunBind { fun_id = L _ mono_id } <- val_bind
  = do withEnv (add_export  mono_id) $ do
       withEnv (add_inlines mono_id) $ do
       val_bind' <- addTickLHsBind val_bind
       return $ L pos $ bind { abs_sig_bind = val_bind' }

  | otherwise
  = pprPanic "addTickLHsBind" (ppr bind)
 where
  -- see AbsBinds comments
  add_export mono_id env
    | idName poly_id `elemNameSet` exports env
    = env { exports = exports env `extendNameSet` idName mono_id }
    | otherwise
    = env

  add_inlines mono_id env
    | isAnyInlinePragma (idInlinePragma poly_id)
    = env { inlines = inlines env `extendVarSet` mono_id }
    | otherwise
    = env
320

321
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
andy@galois.com's avatar
andy@galois.com committed
322 323
  let name = getOccString id
  decl_path <- getPathEntry
324 325 326 327 328 329 330
  density <- getDensity

  inline_ids <- liftM inlines getEnv
  let inline   = isAnyInlinePragma (idInlinePragma id)
                 || id `elemVarSet` inline_ids

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

334
  (fvs, mg@(MG { mg_alts = matches' })) <-
335
        getFreeVars $
336
        addPathEntry name $
337
        addTickMatchGroup False (fun_matches funBind)
338

339
  blackListed <- isBlackListed pos
340
  exported_names <- liftM exports getEnv
341 342

  -- We don't want to generate code for blacklisted positions
343 344 345 346 347 348 349 350 351 352 353 354 355
  -- 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

356
  let mbCons = maybe Prelude.id (:)
357
  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
358
                           , fun_tick = tick `mbCons` fun_tick funBind }
359

360
   where
361 362
   -- a binding is a simple pattern binding if it is a funbind with
   -- zero patterns
363 364
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
365 366

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

372
  -- Should create ticks here?
373
  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
374
  decl_path <- getPathEntry
375
  let top_lev = null decl_path
376
  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
377

378 379 380 381
    -- 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
382

383 384 385 386 387 388
    -- 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
389

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

394

395 396
bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
397 398 399 400 401 402 403 404 405 406 407 408
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


409 410 411 412 413 414 415 416 417 418 419 420 421 422 423
-- Note [inline sccs]
--
-- It should be reasonable to add ticks to INLINE functions; however
-- currently this tickles a bug later on because the SCCfinal pass
-- does not look inside unfoldings to find CostCentres.  It would be
-- difficult to fix that, because SCCfinal currently works on STG and
-- not Core (and since it also generates CostCentres for CAFs,
-- changing this would be difficult too).
--
-- Another reason not to add ticks to INLINE functions is that this
-- sometimes handy for avoiding adding a tick to a particular function
-- (see #6131)
--
-- So for now we do not add any ticks to INLINE functions at all.

424 425 426 427 428
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
429
addTickLHsExpr e@(L pos e0) = do
430 431
  d <- getDensity
  case d of
432
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
433
    TickForCoverage    -> tick_it
434
    TickCallSites      | isCallSite e0      -> tick_it
435 436 437
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
438 439 440 441 442 443 444 445
   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?
addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprRHS e@(L pos e0) = do
446 447
  d <- getDensity
  case d of
448 449
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
450
     TickForCoverage -> tick_it
451
     TickCallSites   | isCallSite e0 -> tick_it
452 453 454
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472
   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.
addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)
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.
473
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
474 475 476 477 478 479 480 481 482
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
483

484
-- version of addTick that does not actually add a tick,
485
-- because the scope of this tick is completely subsumed by
486 487 488 489 490 491
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

492 493
-- general heuristic: expressions which do not denote values are good
-- break points
494 495 496
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {})     = True
isGoodBreakExpr (OpApp {})     = True
497
isGoodBreakExpr _other         = False
498

499 500 501 502 503
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{}  = True
isCallSite OpApp{}  = True
isCallSite _ = False

andy@galois.com's avatar
andy@galois.com committed
504
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
505
addTickLHsExprOptAlt oneOfMany (L pos e0)
506 507 508
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
509 510

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
511 512 513 514 515 516 517
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
518 519 520
-- 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
521 522

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
523
addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
524 525 526
addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _)      = return e
addTickHsExpr e@(HsOverLit _)    = return e
Adam Gundry's avatar
Adam Gundry committed
527
addTickHsExpr e@(HsOverLabel _)  = return e
528 529 530
addTickHsExpr e@(HsLit _)        = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
531 532 533 534 535 536 537
addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1) e2'
  -- This might be a type application. Then don't put a tick around e2,
  -- or dsExpr won't recognize it as a type application any more (#11329).
  -- It doesn't make sense to put a tick on a type anyways.
  where e2'
          | isLHsTypeExpr e2 = return e2
          | otherwise        = addTickLHsExpr e2
538

539 540 541 542 543
addTickHsExpr (OpApp e1 e2 fix e3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsExprNever e2)
                (return fix)
544
                (addTickLHsExpr e3)
545
addTickHsExpr (NegApp e neg) =
546 547 548
        liftM2 NegApp
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan neg)
549
addTickHsExpr (HsPar e) =
550 551
        liftM HsPar (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) =
552 553
        liftM2 SectionL
                (addTickLHsExpr e1)
554
                (addTickLHsExprNever e2)
555 556
addTickHsExpr (SectionR e1 e2) =
        liftM2 SectionR
557
                (addTickLHsExprNever e1)
558
                (addTickLHsExpr e2)
559 560 561 562
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
563 564
addTickHsExpr (HsCase e mgs) =
        liftM2 HsCase
565 566
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
567
                (addTickMatchGroup False mgs)
568 569 570 571 572
addTickHsExpr (HsIf cnd e1 e2 e3) =
        liftM3 (HsIf cnd)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
573 574 575 576
addTickHsExpr (HsMultiIf ty alts)
  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
       ; return $ HsMultiIf ty alts' }
577
addTickHsExpr (HsLet (L l binds) e) =
578
        bindLocals (collectLocalBinders binds) $
579 580 581 582
          liftM2 (HsLet . L l)
                  (addTickHsLocalBinds binds) -- to think about: !patterns.
                  (addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt (L l stmts) srcloc)
583
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
584
       ; return (HsDo cxt (L l stmts') srcloc) }
andy@galois.com's avatar
andy@galois.com committed
585
  where
586 587 588
        forQual = case cxt of
                    ListComp -> Just $ BinBox QualBinBox
                    _        -> Nothing
589 590
addTickHsExpr (ExplicitList ty wit es) =
        liftM3 ExplicitList
591
                (return ty)
592
                (addTickWit wit)
Austin Seipp's avatar
Austin Seipp committed
593
                (mapM (addTickLHsExpr) es)
594
             where addTickWit Nothing = return Nothing
595 596 597
                   addTickWit (Just fln)
                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
                          return (Just fln')
598
addTickHsExpr (ExplicitPArr ty es) =
599 600 601
        liftM2 ExplicitPArr
                (return ty)
                (mapM (addTickLHsExpr) es)
Facundo Domínguez's avatar
Facundo Domínguez committed
602 603 604

addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e

605 606 607 608 609 610 611 612
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' }) }
613

614 615
addTickHsExpr (ExprWithTySig e ty) =
        liftM2 ExprWithTySig
616 617 618
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                    -- for expressions with signatures
                (return ty)
619 620
addTickHsExpr (ArithSeq  ty wit arith_seq) =
        liftM3 ArithSeq
621
                (return ty)
622
                (addTickWit wit)
623
                (addTickArithSeqInfo arith_seq)
624
             where addTickWit Nothing = return Nothing
625
                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
626
                                             return (Just fl')
627 628 629 630 631 632 633

-- We might encounter existing ticks (multiple Coverage passes)
addTickHsExpr (HsTick t e) =
        liftM (HsTick t) (addTickLHsExprNever e)
addTickHsExpr (HsBinTick t0 t1 e) =
        liftM (HsBinTick t0 t1) (addTickLHsExprNever e)

634
addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
635
    e2 <- allocTickBox (ExpBox False) False False pos $
636
                addTickHsExpr e0
637
    return $ unLoc e2
638 639 640 641
addTickHsExpr (PArrSeq   ty arith_seq) =
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
Alan Zimmerman's avatar
Alan Zimmerman committed
642 643 644
addTickHsExpr (HsSCC src nm e) =
        liftM3 HsSCC
                (return src)
645 646
                (return nm)
                (addTickLHsExpr e)
Alan Zimmerman's avatar
Alan Zimmerman committed
647 648 649
addTickHsExpr (HsCoreAnn src nm e) =
        liftM3 HsCoreAnn
                (return src)
650 651
                (return nm)
                (addTickLHsExpr e)
652 653 654 655
addTickHsExpr e@(HsBracket     {})   = return e
addTickHsExpr e@(HsTcBracketOut  {}) = return e
addTickHsExpr e@(HsRnBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {})      = return e
andy@galois.com's avatar
andy@galois.com committed
656
addTickHsExpr (HsProc pat cmdtop) =
657 658 659 660 661 662
        liftM2 HsProc
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
        liftM2 HsWrap
                (return w)
663 664 665 666 667 668
                (addTickHsExpr e)       -- Explicitly no tick on inside

addTickHsExpr (ExprWithTySigOut e ty) =
        liftM2 ExprWithTySigOut
               (addTickLHsExprNever e) -- No need to tick the inner expression
               (return ty)             -- for expressions with signatures
669

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

673 674 675 676
addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)
addTickTupArg (L l (Present e))  = do { e' <- addTickLHsExpr e
                                      ; return (L l (Present e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
677

678
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
679
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
680
  let isOneOfMany = matchesOneOfMany matches
681
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
682
  return $ mg { mg_alts = L l matches' }
andy@galois.com's avatar
andy@galois.com committed
683

684
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
Alan Zimmerman's avatar
Alan Zimmerman committed
685
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
686
  bindLocals (collectPatsBinders pats) $ do
687
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
Alan Zimmerman's avatar
Alan Zimmerman committed
688
    return $ Match mf pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
689

690
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
691
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
692
  bindLocals binders $ do
693
    local_binds' <- addTickHsLocalBinds local_binds
694
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
695
    return $ GRHSs guarded' (L l local_binds')
696
  where
697
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
698

699
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
700
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
701
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
702
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
703 704
  return $ GRHS stmts' expr'

705 706 707 708 709 710 711 712 713 714
addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
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 ->
715
       addTickLHsExprRHS expr
716

717
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
718
addTickLStmts isGuard stmts = do
719 720 721
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

722 723
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
               -> TM ([ExprLStmt Id], a)
724
addTickLStmts' isGuard lstmts res
725
  = bindLocals (collectLStmtsBinders lstmts) $
726 727 728
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
729

730
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
Simon Marlow's avatar
Simon Marlow committed
731 732
addTickStmt _isGuard (LastStmt e noret ret) = do
        liftM3 LastStmt
733
                (addTickLHsExpr e)
Simon Marlow's avatar
Simon Marlow committed
734
                (pure noret)
735
                (addTickSyntaxExpr hpcSrcSpan ret)
736 737
addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
        liftM5 BindStmt
738 739 740 741
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
742
                (return ty)
743 744
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
        liftM4 BodyStmt
745 746 747 748
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
                (return ty)
749 750
addTickStmt _isGuard (LetStmt (L l binds)) = do
        liftM (LetStmt . L l)
751
                (addTickHsLocalBinds binds)
752 753
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
    liftM4 ParStmt
754
        (mapM (addTickStmtAndBinders isGuard) pairs)
755
        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
756
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
757
        (return ty)
Simon Marlow's avatar
Simon Marlow committed
758 759 760
addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
    args' <- mapM (addTickApplicativeArg isGuard) args
    return (ApplicativeStmt args' mb_join body_ty)
761

762 763 764 765
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
766
    t_s <- addTickLStmts isGuard stmts
767 768
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
769 770
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
771
    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
772 773
    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 }
774

775 776 777 778 779 780
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'
781
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
782

783
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
784
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
785
                  | otherwise          = addTickLHsExprRHS e
786

Simon Marlow's avatar
Simon Marlow committed
787 788 789 790 791 792 793 794 795 796 797
addTickApplicativeArg
  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr Id, ApplicativeArg Id Id)
  -> TM (SyntaxExpr Id, ApplicativeArg Id Id)
addTickApplicativeArg isGuard (op, arg) =
  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
 where
  addTickArg (ApplicativeArgOne pat expr) =
    ApplicativeArgOne <$> addTickLPat pat <*> addTickLHsExpr expr
  addTickArg (ApplicativeArgMany stmts ret pat) =
    ApplicativeArgMany
      <$> addTickLStmts isGuard stmts
798
      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
Simon Marlow's avatar
Simon Marlow committed
799 800
      <*> addTickLPat pat

801 802
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
                      -> TM (ParStmtBlock Id Id)
803 804
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
805 806
        (addTickLStmts isGuard stmts)
        (return ids)
807
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
808

andy@galois.com's avatar
andy@galois.com committed
809
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
810 811 812 813 814 815
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
816 817
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

818
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
819
addTickHsValBinds (ValBindsOut binds sigs) =
820 821 822 823 824 825 826
        liftM2 ValBindsOut
                (mapM (\ (rec,binds') ->
                                liftM2 (,)
                                        (return rec)
                                        (addTickLHsBinds binds'))
                        binds)
                (return sigs)
827
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
828

829
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
830
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
831 832 833
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
                (return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
834 835 836

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
837 838 839
        liftM2 IPBind
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
840 841 842

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
843
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
844
        L _ x' <- addTickLHsExpr (L pos x)
845
        return $ syn { syn_expr = x' }
andy@galois.com's avatar
andy@galois.com committed
846 847 848 849 850 851
-- we do not walk into patterns.
addTickLPat :: LPat Id -> TM (LPat Id)
addTickLPat pat = return pat

addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
852 853 854 855 856
        liftM4 HsCmdTop
                (addTickLHsCmd cmd)
                (return tys)
                (return ty)
                (return syntaxtable)
andy@galois.com's avatar
andy@galois.com committed
857

858
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
859 860
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
861
        return $ L pos c1
862 863

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
864 865 866 867 868
addTickHsCmd (HsCmdLam matchgroup) =
        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
869 870 871 872 873 874
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
875 876 877 878
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
        liftM2 HsCmdCase
879 880
                (addTickLHsExpr e)
                (addTickCmdMatchGroup mgs)
881 882
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
        liftM3 (HsCmdIf cnd)
883 884 885
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsCmd c2)
                (addTickLHsCmd c3)
886
addTickHsCmd (HsCmdLet (L l binds) c) =
887
        bindLocals (collectLocalBinders binds) $
888 889 890 891
          liftM2 (HsCmdLet . L l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsCmd c)
addTickHsCmd (HsCmdDo (L l stmts) srcloc)
892
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
893
       ; return (HsCmdDo (L l stmts') srcloc) }