Coverage.hs 50.7 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
#endif
17
import Type
andy@galois.com's avatar
andy@galois.com committed
18
19
20
import HsSyn
import Module
import Outputable
21
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
22
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
23
import SrcLoc
24
import ErrUtils
25
import NameSet hiding (FreeVars)
andy@galois.com's avatar
andy@galois.com committed
26
27
import Name
import Bag
28
29
import CostCentre
import CoreSyn
30
import Id
31
import VarSet
32
33
import Data.List
import FastString
34
import HscTypes
35
import TyCon
36
import UniqSupply
37
import BasicTypes
38
import MonadUtils
39
import Maybes
40
41
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
42

43
44
import Data.Time
import System.Directory
45

46
47
48
import Trace.Hpc.Mix
import Trace.Hpc.Util

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

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

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

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

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

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

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

113
     when (dopt Opt_D_dump_ticked dflags) $
114
         log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle
115
             (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
122
123
124

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


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

            hpc_mod_dir
184
185
              | moduleUnitId mod == mainUnitId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
186

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

        createDirectoryIfMissing True hpc_mod_dir
191
        modTime <- getModificationUTCTime filename
192
        let entries' = [ (hpcPos, box)
193
194
195
196
                       | (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'
197
        mixCreate hpc_mod_dir mod_name
198
199
200
201
202
203
204
205
206
207
208
209
210
                       $ 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
211
  | TickCallSites         -- for stack tracing
212
213
  deriving Eq

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

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

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

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

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

addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
260
addTickLHsBinds = mapBagM addTickLHsBind
andy@galois.com's avatar
andy@galois.com committed
261
262

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

281
282
283
284
285
286
   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
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
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
310

311
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
andy@galois.com's avatar
andy@galois.com committed
312
313
  let name = getOccString id
  decl_path <- getPathEntry
314
315
316
317
318
319
320
  density <- getDensity

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

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

324
  (fvs, mg@(MG { mg_alts = matches' })) <-
325
        getFreeVars $
326
        addPathEntry name $
327
        addTickMatchGroup False (fun_matches funBind)
328

329
  blackListed <- isBlackListed pos
330
  exported_names <- liftM exports getEnv
331
332

  -- We don't want to generate code for blacklisted positions
333
334
335
336
337
338
339
340
341
342
343
344
345
  -- 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

346
  let mbCons = maybe Prelude.id (:)
347
  return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
348
                           , fun_tick = tick `mbCons` fun_tick funBind }
349

350
   where
351
352
   -- a binding is a simple pattern binding if it is a funbind with
   -- zero patterns
353
354
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
355
356

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

362
  -- Should create ticks here?
363
  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
364
  decl_path <- getPathEntry
365
  let top_lev = null decl_path
366
  if not (shouldTickPatBind density top_lev) then return (L pos pat') else do
367

368
369
370
371
    -- 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
372

373
374
375
376
377
378
    -- 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
379

380
381
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
Gergő Érdi's avatar
Gergő Érdi committed
382
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
andy@galois.com's avatar
andy@galois.com committed
383

384

385
386
bindTick
  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
387
388
389
390
391
392
393
394
395
396
397
398
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


399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
-- 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.

414
415
416
417
418
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

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

474
-- version of addTick that does not actually add a tick,
475
-- because the scope of this tick is completely subsumed by
476
477
478
479
480
481
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

482
483
-- general heuristic: expressions which do not denote values are good
-- break points
484
isGoodBreakExpr :: HsExpr Id -> Bool
485
486
487
488
isGoodBreakExpr (HsApp {})        = True
isGoodBreakExpr (HsAppTypeOut {}) = True
isGoodBreakExpr (OpApp {})        = True
isGoodBreakExpr _other            = False
489

490
isCallSite :: HsExpr Id -> Bool
491
492
493
isCallSite HsApp{}        = True
isCallSite HsAppTypeOut{} = True
isCallSite OpApp{}        = True
494
495
isCallSite _ = False

andy@galois.com's avatar
andy@galois.com committed
496
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
497
addTickLHsExprOptAlt oneOfMany (L pos e0)
498
499
500
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
501
502

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
503
504
505
506
507
508
509
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
510
511
512
-- 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
513
514

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
515
addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
516
517
518
addTickHsExpr (HsUnboundVar {})  = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _)      = return e
addTickHsExpr e@(HsOverLit _)    = return e
Adam Gundry's avatar
Adam Gundry committed
519
addTickHsExpr e@(HsOverLabel _)  = return e
520
521
addTickHsExpr e@(HsLit _)        = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
522
addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
523
524
525
526
addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
                                                (addTickLHsExpr      e2)
addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
                                                        (return ty)
527

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

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

594
595
596
597
598
599
600
601
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' }) }
602

603
604
addTickHsExpr (ExprWithTySig e ty) =
        liftM2 ExprWithTySig
605
606
607
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                    -- for expressions with signatures
                (return ty)
608
609
addTickHsExpr (ArithSeq  ty wit arith_seq) =
        liftM3 ArithSeq
610
                (return ty)
611
                (addTickWit wit)
612
                (addTickArithSeqInfo arith_seq)
613
             where addTickWit Nothing = return Nothing
614
                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
615
                                             return (Just fl')
616
617
618
619
620
621
622

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

623
addTickHsExpr (HsTickPragma _ _ _ (L pos e0)) = do
624
    e2 <- allocTickBox (ExpBox False) False False pos $
625
                addTickHsExpr e0
626
    return $ unLoc e2
627
628
629
630
addTickHsExpr (PArrSeq   ty arith_seq) =
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
Alan Zimmerman's avatar
Alan Zimmerman committed
631
632
633
addTickHsExpr (HsSCC src nm e) =
        liftM3 HsSCC
                (return src)
634
635
                (return nm)
                (addTickLHsExpr e)
Alan Zimmerman's avatar
Alan Zimmerman committed
636
637
638
addTickHsExpr (HsCoreAnn src nm e) =
        liftM3 HsCoreAnn
                (return src)
639
640
                (return nm)
                (addTickLHsExpr e)
641
642
643
644
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
645
addTickHsExpr (HsProc pat cmdtop) =
646
647
648
649
650
651
        liftM2 HsProc
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
        liftM2 HsWrap
                (return w)
652
653
654
655
656
657
                (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
658

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

662
663
664
665
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))
666

667
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
668
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
669
  let isOneOfMany = matchesOneOfMany matches
670
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
671
  return $ mg { mg_alts = L l matches' }
andy@galois.com's avatar
andy@galois.com committed
672

673
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
Alan Zimmerman's avatar
Alan Zimmerman committed
674
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
675
  bindLocals (collectPatsBinders pats) $ do
676
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
Alan Zimmerman's avatar
Alan Zimmerman committed
677
    return $ Match mf pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
678

679
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
680
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
681
  bindLocals binders $ do
682
    local_binds' <- addTickHsLocalBinds local_binds
683
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
684
    return $ GRHSs guarded' (L l local_binds')
685
  where
686
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
687

688
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
689
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
690
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
691
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
692
693
  return $ GRHS stmts' expr'

694
695
696
697
698
699
700
701
702
703
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 ->
704
       addTickLHsExprRHS expr
705

706
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
707
addTickLStmts isGuard stmts = do
708
709
710
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

711
712
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
               -> TM ([ExprLStmt Id], a)
713
addTickLStmts' isGuard lstmts res
714
  = bindLocals (collectLStmtsBinders lstmts) $
715
716
717
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
718

719
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
Simon Marlow's avatar
Simon Marlow committed
720
721
addTickStmt _isGuard (LastStmt e noret ret) = do
        liftM3 LastStmt
722
                (addTickLHsExpr e)
Simon Marlow's avatar
Simon Marlow committed
723
                (pure noret)
724
                (addTickSyntaxExpr hpcSrcSpan ret)
725
726
addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
        liftM5 BindStmt
727
728
729
730
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
731
                (return ty)
732
733
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
        liftM4 BodyStmt
734
735
736
737
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
                (return ty)
738
739
addTickStmt _isGuard (LetStmt (L l binds)) = do
        liftM (LetStmt . L l)
740
                (addTickHsLocalBinds binds)
741
742
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
    liftM4 ParStmt
743
        (mapM (addTickStmtAndBinders isGuard) pairs)
744
        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
745
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
746
        (return ty)
Simon Marlow's avatar
Simon Marlow committed
747
748
749
addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
    args' <- mapM (addTickApplicativeArg isGuard) args
    return (ApplicativeStmt args' mb_join body_ty)
750

751
752
753
754
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
755
    t_s <- addTickLStmts isGuard stmts
756
757
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
758
759
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
760
    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
761
762
    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 }
763

764
765
766
767
768
769
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'
770
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
771

772
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
773
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
774
                  | otherwise          = addTickLHsExprRHS e
775

Simon Marlow's avatar
Simon Marlow committed
776
777
778
779
780
781
782
783
784
785
786
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
787
      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
Simon Marlow's avatar
Simon Marlow committed
788
789
      <*> addTickLPat pat

790
791
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
                      -> TM (ParStmtBlock Id Id)
792
793
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
794
795
        (addTickLStmts isGuard stmts)
        (return ids)
796
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
797

andy@galois.com's avatar
andy@galois.com committed
798
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
799
800
801
802
803
804
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
805
806
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

807
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
808
addTickHsValBinds (ValBindsOut binds sigs) =
809
810
811
812
813
814
815
        liftM2 ValBindsOut
                (mapM (\ (rec,binds') ->
                                liftM2 (,)
                                        (return rec)
                                        (addTickLHsBinds binds'))
                        binds)
                (return sigs)
816
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
817

818
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
819
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
820
821
822
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
                (return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
823
824
825

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
826
827
828
        liftM2 IPBind
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
829
830
831

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
832
addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
833
        L _ x' <- addTickLHsExpr (L pos x)
834
        return $ syn { syn_expr = x' }
andy@galois.com's avatar
andy@galois.com committed
835
836
837
838
839
840
-- 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) =
841
842
843
844
845
        liftM4 HsCmdTop
                (addTickLHsCmd cmd)
                (return tys)
                (return ty)
                (return syntaxtable)
andy@galois.com's avatar
andy@galois.com committed
846

847
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
848
849
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
850
        return $ L pos c1
851
852

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
853
854
855
856
857
addTickHsCmd (HsCmdLam matchgroup) =
        liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
        liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
858
859
860
861
862
863
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
864
865
866
867
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
        liftM2 HsCmdCase
868
869
                (addTickLHsExpr e)
                (addTickCmdMatchGroup mgs)
870
871
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
        liftM3 (HsCmdIf cnd)
872
873
874
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsCmd c2)
                (addTickLHsCmd c3)
875
addTickHsCmd (HsCmdLet (L l binds) c) =
876
        bindLocals (collectLocalBinders binds) $
877
878
879
880
          liftM2 (HsCmdLet . L l)
                   (addTickHsLocalBinds binds) -- to think about: !patterns.
                   (addTickLHsCmd c)
addTickHsCmd (HsCmdDo (L l stmts) srcloc)
881
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
882
       ; return (HsCmdDo (L l stmts') srcloc) }
883

884
885
addTickHsCmd (HsCmdArrApp   e1 e2 ty1 arr_ty lr) =
        liftM5 HsCmdArrApp
886
887
888
889
890
               (addTickLHsExpr e1)
               (addTickLHsExpr e2)
               (return ty1)
               (return arr_ty)
               (return lr)
891
892
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
        liftM3 HsCmdArrForm
893
894
895
               (addTickLHsExpr e)
               (return fix)
               (mapM (liftL (addTickHsCmdTop)) cmdtop)
896

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
897
898
addTickHsCmd (HsCmdWrap w cmd)
  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
899

900
-- Others should never happen in a command context.
901
--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
902

903
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
904
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
905
  matches' <- mapM (liftL addTickCmdMatch) matches
906
  return $ mg { mg_alts = L l matches' }
907

908
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
Alan Zimmerman's avatar
Alan Zimmerman committed
909
addTickCmdMatch (Match mf pats opSig gRHSs) =
910
911
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickCmdGRHSs gRHSs
Alan Zimmerman's avatar
Alan Zimmerman committed
912
    return $ Match mf pats opSig gRHSs'
913

914
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
915
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
916
917
918
  bindLocals binders $ do
    local_binds' <- addTickHsLocalBinds local_binds
    guarded' <- mapM (liftL addTickCmdGRHS) guarded
919
    return $ GRHSs guarded' (L l local_binds')
920
921
922
  where
    binders = collectLocalBinders local_binds

923
addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
924
925
926
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
927
  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
928
929
                                   stmts (addTickLHsCmd cmd)
       ; return $ GRHS stmts' expr' }
930

931
addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
932
933
934
935
addTickLCmdStmts stmts = do
  (stmts, _) <- addTickLCmdStmts' stmts (return ())
  return stmts

936
addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
937
938
939
940
941
942
943
944
addTickLCmdStmts' lstmts res
  = bindLocals binders $ do
        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
        a <- res
        return (lstmts', a)
  where
        binders = collectLStmtsBinders lstmts

945
addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
946
947
addTickCmdStmt (BindStmt pat c bind fail ty) = do
        liftM5 BindStmt
948
949
950
951
                (addTickLPat pat)
                (addTickLHsCmd c)
                (return bind)
                (return fail)
952
                (return ty)
<