Coverage.lhs 44.8 KB
Newer Older
andy@galois.com's avatar
andy@galois.com committed
1
2
%
% (c) Galois, 2006
3
% (c) University of Glasgow, 2007
andy@galois.com's avatar
andy@galois.com committed
4
5
%
\begin{code}
6
module Coverage (addTicksToBinds, hpcInitCode) where
andy@galois.com's avatar
andy@galois.com committed
7

8
import Type
andy@galois.com's avatar
andy@galois.com committed
9
10
11
import HsSyn
import Module
import Outputable
12
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
13
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
14
import SrcLoc
15
import ErrUtils
16
import NameSet hiding (FreeVars)
andy@galois.com's avatar
andy@galois.com committed
17
18
import Name
import Bag
19
20
import CostCentre
import CoreSyn
21
import Id
22
import VarSet
23
24
import Data.List
import FastString
25
import HscTypes
26
import StaticFlags
27
import TyCon
28
import Unique
29
import BasicTypes
30
import MonadUtils
31
import Maybes
32
33
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
34

35
import Data.Array
36
37
import Data.Time
import System.Directory
38

39
40
41
import Trace.Hpc.Mix
import Trace.Hpc.Util

42
import BreakArray
43
44
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
45
46
\end{code}

47

andy@galois.com's avatar
andy@galois.com committed
48
%************************************************************************
49
%*                                                                      *
50
%*              The main function: addTicksToBinds
51
%*                                                                      *
andy@galois.com's avatar
andy@galois.com committed
52
53
54
%************************************************************************

\begin{code}
55
addTicksToBinds
56
57
        :: DynFlags
        -> Module
58
59
60
61
62
        -> 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
63
        -> LHsBinds Id
64
        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
65

66
addTicksToBinds dflags mod mod_loc exports tyCons binds =
67

68
69
70
 case ml_hs_file mod_loc of
   Nothing        -> return (binds, emptyHpcInfo False, emptyModBreaks)
   Just orig_file -> do
71

72
73
74
     if "boot" `isSuffixOf` orig_file
         then return (binds, emptyHpcInfo False, emptyModBreaks)
         else do
75

76
     let  orig_file2 = guessSourceFile binds orig_file
andy@galois.com's avatar
andy@galois.com committed
77

78
          (binds1,_,st)
79
80
                 = unTM (addTickLHsBinds binds)
                   (TTE
81
                      { fileName     = mkFastString orig_file2
82
                      , declPath     = []
83
                      , tte_dflags   = dflags
84
                      , exports      = exports
85
                      , inlines      = emptyVarSet
86
                      , inScope      = emptyVarSet
87
88
89
90
91
                      , blackList    = Map.fromList
                                          [ (getSrcSpan (tyConName tyCon),())
                                          | tyCon <- tyCons ]
                      , density      = mkDensity dflags
                      , this_mod     = mod
92
93
94
95
96
97
                      , tickishType  = case hscTarget dflags of
                          HscInterpreted          -> Breakpoints
                          _ | opt_Hpc             -> HpcTicks
                            | dopt Opt_SccProfilingOn dflags
                                                  -> ProfNotes
                            | otherwise           -> error "addTicksToBinds: No way to annotate!"
98
                       })
99
100
101
102
                   (TT
                      { tickBoxCount = 0
                      , mixEntries   = []
                      })
andy@galois.com's avatar
andy@galois.com committed
103

104
     let entries = reverse $ mixEntries st
105

106
107
108
     let count = tickBoxCount st
     hashNo <- writeMixEntries dflags mod count entries orig_file2
     modBreaks <- mkModBreaks count entries
andy@galois.com's avatar
andy@galois.com committed
109

110
     doIfSet_dyn dflags Opt_D_dump_ticked $
Ian Lynagh's avatar
Ian Lynagh committed
111
         log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
112
             (pprLHsBinds binds1)
113

114
     return (binds1, HpcInfo count hashNo, modBreaks)
andy@galois.com's avatar
andy@galois.com committed
115

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136

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.
     let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
                                 srcSpanFileName_maybe pos : rest) [] binds
     in
     case top_pos of
        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
                      -> unpackFS file_name
        _ -> orig_file


mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks
mkModBreaks count entries = do
  breakArray <- newBreakArray $ length 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 ]
137
138
139
         modBreaks = emptyModBreaks
                     { modBreaks_flags = breakArray
                     , modBreaks_locs  = locsTicks
140
141
                     , modBreaks_vars  = varsTicks
                     , modBreaks_decls = declsTicks
142
                     }
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
  --
  return modBreaks


writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
writeMixEntries dflags mod count entries filename
  | not opt_Hpc = return 0
  | otherwise   = do
        let
            hpc_dir = hpcDir dflags
            mod_name = moduleNameString (moduleName mod)

            hpc_mod_dir
              | modulePackageId mod == mainPackageId  = hpc_dir
              | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
158

159
160
161
            tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.

        createDirectoryIfMissing True hpc_mod_dir
162
        modTime <- getModificationUTCTime filename
163
        let entries' = [ (hpcPos, box)
164
165
166
167
                       | (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'
168
        mixCreate hpc_mod_dir mod_name
169
170
171
172
173
174
175
176
177
178
179
180
181
                       $ 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
182
  | TickCallSites         -- for stack tracing
183
184
185
186
187
188
189
190
191
  deriving Eq

mkDensity :: DynFlags -> TickDensity
mkDensity dflags
  | opt_Hpc                              = TickForCoverage
  | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints
  | ProfAutoAll     <- profAuto dflags   = TickAllFunctions
  | ProfAutoTop     <- profAuto dflags   = TickTopFunctions
  | ProfAutoExports <- profAuto dflags   = TickExportedFunctions
192
  | ProfAutoCalls   <- profAuto dflags   = TickCallSites
193
  | otherwise = panic "desnity"
194
195
196
197
198
  -- ToDo: -fhpc is taking priority over -fprof-auto here.  It seems
  -- that coverage works perfectly well with profiling, but you don't
  -- get any auto-generated SCCs.  It would make perfect sense to
  -- allow both of them, and indeed to combine some of the other flags
  -- (-fprof-auto-calls -fprof-auto-top, for example)
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216

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

shouldTickBind density top_lev exported simple_pat inline
 = case density of
      TickForBreakPoints    -> not simple_pat
        -- 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
217
      TickCallSites         -> False
218
219
220
221
222
223
224
225
226

shouldTickPatBind :: TickDensity -> Bool -> Bool
shouldTickPatBind density top_lev
  = case density of
      TickForBreakPoints    -> False
      TickAllFunctions      -> True
      TickTopFunctions      -> top_lev
      TickExportedFunctions -> False
      TickForCoverage       -> False
227
      TickCallSites         -> False
228
229
230

-- -----------------------------------------------------------------------------
-- Adding ticks to bindings
andy@galois.com's avatar
andy@galois.com committed
231
232
233
234
235

addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTickLHsBind binds

addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
236
237
238
addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
                                       abs_exports = abs_exports })) = do
  withEnv add_exports $ do
239
  withEnv add_inlines $ do
240
241
  binds' <- addTickLHsBinds binds
  return $ L pos $ bind { abs_binds = binds' }
242
243
244
245
246
247
248
249
250
251
252
253
 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 =
     env{ exports = exports env `addListToNameSet`
                      [ idName mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , idName pid `elemNameSet` (exports env) ] }

254
255
256
257
258
259
260
   add_inlines env =
     env{ inlines = inlines env `extendVarSetList`
                      [ mid
                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
                      , isAnyInlinePragma (idInlinePragma pid) ] }


261
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
262
263
  env <- getEnv
  let dflags = tte_dflags env
andy@galois.com's avatar
andy@galois.com committed
264
265
  let name = getOccString id
  decl_path <- getPathEntry
266
267
268
269
270
271
272
  density <- getDensity

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

  -- See Note [inline sccs]
273
  if inline && dopt Opt_SccProfilingOn dflags then return (L pos funBind) else do
andy@galois.com's avatar
andy@galois.com committed
274

275
  (fvs, (MatchGroup matches' ty)) <-
276
        getFreeVars $
277
        addPathEntry name $
278
        addTickMatchGroup False (fun_matches funBind)
279

280
  blackListed <- isBlackListed pos
281
  exported_names <- liftM exports getEnv
282
283

  -- We don't want to generate code for blacklisted positions
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
  -- 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

  return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
                           , fun_tick = tick }

300
301
302
303
   where
   -- a binding is a simple pattern binding if it is a funbind with zero patterns
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
304
305

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

  density <- getDensity
andy@galois.com's avatar
andy@galois.com committed
311
  decl_path <- getPathEntry
312
313
314
315
316
317
318
319
320
321
322
323
324
325
  let top_lev = null decl_path
  let add_ticks = shouldTickPatBind density top_lev

  tickish <- if add_ticks
                then bindTick density name pos fvs
                else return Nothing

  let patvars = map getOccString (collectPatBinders lhs)
  patvar_ticks <- if add_ticks
                     then mapM (\v -> bindTick density v pos fvs) patvars
                     else return []

  return $ L pos $ pat { pat_rhs = rhs',
                         pat_ticks = (tickish, patvar_ticks)}
andy@galois.com's avatar
andy@galois.com committed
326

327
328
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
andy@galois.com's avatar
andy@galois.com committed
329

330
331
332
333
334
335
336
337
338
339
340
341
342
343

bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
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


344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
-- 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.

359
360
361
362
363
-- -----------------------------------------------------------------------------
-- Decorate an LHsExpr with ticks

-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
364
addTickLHsExpr e@(L pos e0) = do
365
366
  d <- getDensity
  case d of
367
    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
368
    TickForCoverage    -> tick_it
369
    TickCallSites      | isCallSite e0      -> tick_it
370
371
372
    _other             -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
373
374
375
376
377
378
379
380
   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
381
382
  d <- getDensity
  case d of
383
384
     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                        | otherwise     -> tick_it
385
     TickForCoverage -> tick_it
386
     TickCallSites   | isCallSite e0 -> tick_it
387
388
389
     _other          -> dont_tick_it
 where
   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
   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.
408
addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
409
410
411
412
413
414
415
416
417
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
418

419
-- version of addTick that does not actually add a tick,
420
-- because the scope of this tick is completely subsumed by
421
422
423
424
425
426
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

427
428
429
430
431
432
-- general heuristic: expressions which do not denote values are good break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {})     = True
isGoodBreakExpr (OpApp {})     = True
isGoodBreakExpr (NegApp {})    = True
isGoodBreakExpr (HsIf {})      = True
433
isGoodBreakExpr (HsMultiIf {}) = True
434
isGoodBreakExpr (HsCase {})    = True
435
436
437
438
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {})  = True
isGoodBreakExpr (PArrSeq {})   = True
439
isGoodBreakExpr _other         = False
440

441
442
443
444
445
isCallSite :: HsExpr Id -> Bool
isCallSite HsApp{}  = True
isCallSite OpApp{}  = True
isCallSite _ = False

andy@galois.com's avatar
andy@galois.com committed
446
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
447
addTickLHsExprOptAlt oneOfMany (L pos e0)
448
449
450
  = ifDensity TickForCoverage
        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))
andy@galois.com's avatar
andy@galois.com committed
451
452

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
453
454
455
456
457
458
459
460
addBinTickLHsExpr boxLabel (L pos e0)
  = ifDensity TickForCoverage
        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
        (addTickLHsExpr (L pos e0))


-- -----------------------------------------------------------------------------
-- Decoarate an HsExpr with ticks
andy@galois.com's avatar
andy@galois.com committed
461
462

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
463
addTickHsExpr e@(HsVar id) = do freeVar id; return e
andy@galois.com's avatar
andy@galois.com committed
464
465
466
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
467
addTickHsExpr (HsLam matchgroup) =
468
        liftM HsLam (addTickMatchGroup True matchgroup)
469
470
addTickHsExpr (HsLamCase ty mgs) =
        liftM (HsLamCase ty) (addTickMatchGroup True mgs)
471
addTickHsExpr (HsApp e1 e2) =
472
473
474
475
476
477
        liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsExpr (OpApp e1 e2 fix e3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsExprNever e2)
                (return fix)
478
                (addTickLHsExpr e3)
479
addTickHsExpr (NegApp e neg) =
480
481
482
        liftM2 NegApp
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan neg)
483
addTickHsExpr (HsPar e) =
484
485
        liftM HsPar (addTickLHsExprEvalInner e)
addTickHsExpr (SectionL e1 e2) =
486
487
        liftM2 SectionL
                (addTickLHsExpr e1)
488
                (addTickLHsExprNever e2)
489
490
addTickHsExpr (SectionR e1 e2) =
        liftM2 SectionR
491
                (addTickLHsExprNever e1)
492
                (addTickLHsExpr e2)
493
494
495
496
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
497
498
addTickHsExpr (HsCase e mgs) =
        liftM2 HsCase
499
500
                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                   -- be evaluated.
501
                (addTickMatchGroup False mgs)
502
503
504
505
506
addTickHsExpr (HsIf cnd e1 e2 e3) =
        liftM3 (HsIf cnd)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsExprOptAlt True e2)
                (addTickLHsExprOptAlt True e3)
507
508
509
510
addTickHsExpr (HsMultiIf ty alts)
  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
       ; return $ HsMultiIf ty alts' }
andy@galois.com's avatar
andy@galois.com committed
511
addTickHsExpr (HsLet binds e) =
512
513
514
        bindLocals (collectLocalBinders binds) $
        liftM2 HsLet
                (addTickHsLocalBinds binds) -- to think about: !patterns.
515
                (addTickLHsExprLetBody e)
516
addTickHsExpr (HsDo cxt stmts srcloc)
517
518
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
andy@galois.com's avatar
andy@galois.com committed
519
  where
520
521
522
523
524
525
526
        forQual = case cxt of
                    ListComp -> Just $ BinBox QualBinBox
                    _        -> Nothing
addTickHsExpr (ExplicitList ty es) =
        liftM2 ExplicitList
                (return ty)
                (mapM (addTickLHsExpr) es)
527
addTickHsExpr (ExplicitPArr ty es) =
528
529
530
531
532
533
534
535
        liftM2 ExplicitPArr
                (return ty)
                (mapM (addTickLHsExpr) es)
addTickHsExpr (RecordCon id ty rec_binds) =
        liftM3 RecordCon
                (return id)
                (return ty)
                (addTickHsRecordBinds rec_binds)
536
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
537
538
539
540
        liftM5 RecordUpd
                (addTickLHsExpr e)
                (addTickHsRecordBinds rec_binds)
                (return cons) (return tys1) (return tys2)
541

andy@galois.com's avatar
andy@galois.com committed
542
addTickHsExpr (ExprWithTySigOut e ty) =
543
544
545
546
547
548
549
550
        liftM2 ExprWithTySigOut
                (addTickLHsExprNever e) -- No need to tick the inner expression
                                    -- for expressions with signatures
                (return ty)
addTickHsExpr (ArithSeq  ty arith_seq) =
        liftM2 ArithSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
551
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
552
    e2 <- allocTickBox (ExpBox False) False False pos $
553
                addTickHsExpr e0
554
    return $ unLoc e2
555
556
557
558
addTickHsExpr (PArrSeq   ty arith_seq) =
        liftM2 PArrSeq
                (return ty)
                (addTickArithSeqInfo arith_seq)
559
addTickHsExpr (HsSCC nm e) =
560
        liftM2 HsSCC
561
562
                (return nm)
                (addTickLHsExpr e)
563
564
addTickHsExpr (HsCoreAnn nm e) =
        liftM2 HsCoreAnn
565
566
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
567
568
569
570
addTickHsExpr e@(HsBracket     {}) = return e
addTickHsExpr e@(HsBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
571
572
573
574
575
576
577
        liftM2 HsProc
                (addTickLPat pat)
                (liftL (addTickHsCmdTop) cmdtop)
addTickHsExpr (HsWrap w e) =
        liftM2 HsWrap
                (return w)
                (addTickHsExpr e)       -- explicitly no tick on inside
578

579
addTickHsExpr e@(HsType _) = return e
580

581
-- Others dhould never happen in expression content.
582
addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
andy@galois.com's avatar
andy@galois.com committed
583

584
585
586
587
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)

588
589
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup is_lam (MatchGroup matches ty) = do
590
  let isOneOfMany = matchesOneOfMany matches
591
  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
andy@galois.com's avatar
andy@galois.com committed
592
593
  return $ MatchGroup matches' ty

594
595
addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
596
  bindLocals (collectPatsBinders pats) $ do
597
    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
598
    return $ Match pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
599

600
601
addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
602
  bindLocals binders $ do
603
    local_binds' <- addTickHsLocalBinds local_binds
604
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
605
606
    return $ GRHSs guarded' local_binds'
  where
607
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
608

609
610
addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
611
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
612
                        (addTickGRHSBody isOneOfMany isLambda expr)
andy@galois.com's avatar
andy@galois.com committed
613
614
  return $ GRHS stmts' expr'

615
616
617
618
619
620
621
622
623
624
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 ->
625
       addTickLHsExprRHS expr
626

627
628
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
629
630
631
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

632
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
633
634
               -> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
635
  = bindLocals (collectLStmtsBinders lstmts) $
636
637
638
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
639
640

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
641
addTickStmt _isGuard (LastStmt e ret) = do
642
643
644
        liftM2 LastStmt
                (addTickLHsExpr e)
                (addTickSyntaxExpr hpcSrcSpan ret)
645
addTickStmt _isGuard (BindStmt pat e bind fail) = do
646
647
648
649
650
        liftM4 BindStmt
                (addTickLPat pat)
                (addTickLHsExprRHS e)
                (addTickSyntaxExpr hpcSrcSpan bind)
                (addTickSyntaxExpr hpcSrcSpan fail)
651
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
652
653
654
655
656
        liftM4 ExprStmt
                (addTick isGuard e)
                (addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
                (return ty)
657
addTickStmt _isGuard (LetStmt binds) = do
658
659
        liftM LetStmt
                (addTickHsLocalBinds binds)
660
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
661
    liftM3 ParStmt
662
        (mapM (addTickStmtAndBinders isGuard) pairs)
663
664
665
        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
        (addTickSyntaxExpr hpcSrcSpan bindExpr)

666
667
668
669
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                    , trS_by = by, trS_using = using
                                    , trS_ret = returnExpr, trS_bind = bindExpr
                                    , trS_fmap = liftMExpr }) = do
670
    t_s <- addTickLStmts isGuard stmts
671
672
    t_y <- fmapMaybeM  addTickLHsExprRHS by
    t_u <- addTickLHsExprRHS using
673
674
675
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
676
677
    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 }
678

679
680
681
682
683
684
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'
685
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
686

687
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
688
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
689
                  | otherwise          = addTickLHsExprRHS e
690

691
692
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
                      -> TM (ParStmtBlock Id Id)
693
694
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
    liftM3 ParStmtBlock
695
696
        (addTickLStmts isGuard stmts)
        (return ids)
697
        (addTickSyntaxExpr hpcSrcSpan returnExpr)
698

andy@galois.com's avatar
andy@galois.com committed
699
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
700
701
702
703
704
705
addTickHsLocalBinds (HsValBinds binds) =
        liftM HsValBinds
                (addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  =
        liftM HsIPBinds
                (addTickHsIPBinds binds)
andy@galois.com's avatar
andy@galois.com committed
706
707
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

708
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
709
addTickHsValBinds (ValBindsOut binds sigs) =
710
711
712
713
714
715
716
        liftM2 ValBindsOut
                (mapM (\ (rec,binds') ->
                                liftM2 (,)
                                        (return rec)
                                        (addTickLHsBinds binds'))
                        binds)
                (return sigs)
717
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
718

719
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
720
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
721
722
723
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
                (return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
724
725
726

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
727
728
729
        liftM2 IPBind
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
730
731
732
733

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
addTickSyntaxExpr pos x = do
734
735
        L _ x' <- addTickLHsExpr (L pos x)
        return $ x'
andy@galois.com's avatar
andy@galois.com committed
736
737
738
739
740
741
-- 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) =
742
743
744
745
746
        liftM4 HsCmdTop
                (addTickLHsCmd cmd)
                (return tys)
                (return ty)
                (return syntaxtable)
andy@galois.com's avatar
andy@galois.com committed
747

748
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
749
750
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
751
        return $ L pos c1
752
753
754
755

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
        liftM HsLam (addTickCmdMatchGroup matchgroup)
756
757
758
759
760
761
762
763
addTickHsCmd (HsApp c e) =
        liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
addTickHsCmd (OpApp e1 c2 fix c3) =
        liftM4 OpApp
                (addTickLHsExpr e1)
                (addTickLHsCmd c2)
                (return fix)
                (addTickLHsCmd c3)
764
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
765
766
767
768
769
770
771
772
773
addTickHsCmd (HsCase e mgs) =
        liftM2 HsCase
                (addTickLHsExpr e)
                (addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) =
        liftM3 (HsIf cnd)
                (addBinTickLHsExpr (BinBox CondBinBox) e1)
                (addTickLHsCmd c2)
                (addTickLHsCmd c3)
774
addTickHsCmd (HsLet binds c) =
775
776
777
        bindLocals (collectLocalBinders binds) $
        liftM2 HsLet
                (addTickHsLocalBinds binds) -- to think about: !patterns.
778
                (addTickLHsCmd c)
779
780
781
addTickHsCmd (HsDo cxt stmts srcloc)
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
782

783
addTickHsCmd (HsArrApp   e1 e2 ty1 arr_ty lr) =
784
        liftM5 HsArrApp
785
786
787
788
789
790
               (addTickLHsExpr e1)
               (addTickLHsExpr e2)
               (return ty1)
               (return arr_ty)
               (return lr)
addTickHsCmd (HsArrForm e fix cmdtop) =
791
        liftM3 HsArrForm
792
793
794
               (addTickLHsExpr e)
               (return fix)
               (mapM (liftL (addTickHsCmdTop)) cmdtop)
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819

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

addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickCmdMatchGroup (MatchGroup matches ty) = do
  matches' <- mapM (liftL addTickCmdMatch) matches
  return $ MatchGroup matches' ty

addTickCmdMatch :: Match Id -> TM (Match Id)
addTickCmdMatch (Match pats opSig gRHSs) =
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickCmdGRHSs gRHSs
    return $ Match pats opSig gRHSs'

addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
addTickCmdGRHSs (GRHSs guarded local_binds) = do
  bindLocals binders $ do
    local_binds' <- addTickHsLocalBinds local_binds
    guarded' <- mapM (liftL addTickCmdGRHS) guarded
    return $ GRHSs guarded' local_binds'
  where
    binders = collectLocalBinders local_binds

addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
820
821
822
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
823
  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
824
825
                                   stmts (addTickLHsCmd cmd)
       ; return $ GRHS stmts' expr' }
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842

addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts stmts = do
  (stmts, _) <- addTickLCmdStmts' stmts (return ())
  return stmts

addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
addTickLCmdStmts' lstmts res
  = bindLocals binders $ do
        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
        a <- res
        return (lstmts', a)
  where
        binders = collectLStmtsBinders lstmts

addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt (BindStmt pat c bind fail) = do
843
844
845
846
847
        liftM4 BindStmt
                (addTickLPat pat)
                (addTickLHsCmd c)
                (return bind)
                (return fail)
848
addTickCmdStmt (LastStmt c ret) = do
849
850
851
        liftM2 LastStmt
                (addTickLHsCmd c)
                (addTickSyntaxExpr hpcSrcSpan ret)
852
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
853
854
855
        liftM4 ExprStmt
                (addTickLHsCmd c)
                (addTickSyntaxExpr hpcSrcSpan bind')
856
                (addTickSyntaxExpr hpcSrcSpan guard')
857
                (return ty)
858
addTickCmdStmt (LetStmt binds) = do
859
860
        liftM LetStmt
                (addTickHsLocalBinds binds)
861
862
863
864
865
866
867
868
869
870
addTickCmdStmt stmt@(RecStmt {})
  = do { stmts' <- addTickLCmdStmts (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'
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }

-- Others should never happen in a command context.
addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
andy@galois.com's avatar
andy@galois.com committed
871
872

addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
873
874
875
addTickHsRecordBinds (HsRecFields fields dd)
  = do  { fields' <- mapM process fields
        ; return (HsRecFields fields' dd) }
876
877
  where
    process (HsRecField ids expr doc)
878
879
        = do { expr' <- addTickLHsExpr expr
             ; return (HsRecField ids expr' doc) }
andy@galois.com's avatar
andy@galois.com committed
880
881
882

addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
883
884
        liftM From
                (addTickLHsExpr e1)
andy@galois.com's avatar
andy@galois.com committed
885
addTickArithSeqInfo (FromThen e1 e2) =
886
887
888
        liftM2 FromThen
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
889
addTickArithSeqInfo (FromTo e1 e2) =
890
891
892
        liftM2 FromTo
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
893
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
894
895
896
897
        liftM3 FromThenTo
                (addTickLHsExpr e1)
                (addTickLHsExpr e2)
                (addTickLHsExpr e3)
898
899
900
901
902

liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
  a' <- f a
  return $ L loc a'
andy@galois.com's avatar
andy@galois.com committed
903
904
905
\end{code}

\begin{code}
906
data TickTransState = TT { tickBoxCount:: Int
907
                         , mixEntries  :: [MixEntry_]
908
                         }
909

910
911
data TickTransEnv = TTE { fileName     :: FastString
                        , density      :: TickDensity
912
                        , tte_dflags   :: DynFlags
913
                        , exports      :: NameSet
914
                        , inlines      :: VarSet
915
                        , declPath     :: [String]
916
                        , inScope      :: VarSet
917
918
                        , blackList    :: Map SrcSpan ()
                        , this_mod     :: Module
919
                        , tickishType  :: TickishType
920
                        }
921

922
--      deriving Show
andy@galois.com's avatar
andy@galois.com committed
923

924
925
926
927
928
929
930
931
932
933
data TickishType = ProfNotes | HpcTicks | Breakpoints


-- | Tickishs that only make sense when their source code location
-- refers to the current file. This might not always be true due to
-- LINE pragmas in the code - which would confuse at least HPC.
tickSameFileOnly :: TickishType -> Bool
tickSameFileOnly HpcTicks = True
tickSameFileOnly _other   = False

934
type FreeVars = OccEnv Id
935
noFVs :: FreeVars
936
937
938
939
940
941
942
943
944
945
946
947
948
949
noFVs = emptyOccEnv

-- Note [freevars]
--   For breakpoints we want to collect the free variables of an
--   expression for pinning on the HsTick.  We don't want to collect
--   *all* free variables though: in particular there's no point pinning
--   on free variables that are will otherwise be in scope at the GHCi
--   prompt, which means all top-level bindings.  Unfortunately detecting
--   top-level bindings isn't easy (collectHsBindsBinders on the top-level
--   bindings doesn't do it), so we keep track of a set of "in-scope"
--   variables in addition to the free variables, and the former is used
--   to filter additions to the latter.  This gives us complete control
--   over what free variables we track.

950
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
951
952
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).
andy@galois.com's avatar
andy@galois.com committed
953
954

instance Monad TM where
955
  return a = TM $ \ _env st -> (a,noFVs,st)
956
957
958
  (TM m) >>= k = TM $ \ env st ->
                                case m env st of
                                  (r1,fv1,st1) ->
959
                                     case unTM (k r1) env st1 of
960
                                       (r2,fv2,st2) ->
961
962
                                          (r2, fv1 `plusOccEnv` fv2, st2)

Simon Marlow's avatar
Simon Marlow committed
963
964
-- getState :: TM TickTransState
-- getState = TM $ \ env st -> (st, noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
965

966
967
-- setState :: (TickTransState -> TickTransState) -> TM ()
-- setState f = TM $ \ env st -> ((), noFVs, f st)
968

969
970
971
972
getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)

withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
973
974
withEnv f (TM m) = TM $ \ env st ->
                                 case m (f env) st of
975
976
                                   (a, fvs, st') -> (a, fvs, st')

977
978
979
980
981
982
getDensity :: TM TickDensity
getDensity = TM $ \env st -> (density env, noFVs, st)

ifDensity :: TickDensity -> TM a -> TM a -> TM a
ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el

983
getFreeVars :: TM a -> TM (FreeVars, a)
984
getFreeVars (TM m)
985
  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
986
987

freeVar :: Id -> TM ()
988
freeVar id = TM $ \ env st ->
989
                if id `elemVarSet` inScope env
990
991
                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
                   else ((), noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
992

993
994
addPathEntry :: String -> TM a -> TM a
addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
andy@galois.com's avatar
andy@galois.com committed
995
996

getPathEntry :: TM [String]
997
getPathEntry = declPath `liftM` getEnv
998

999
1000
1001
getFileName :: TM FastString
getFileName = fileName `liftM` getEnv

1002
1003
1004
1005
1006
1007
isGoodSrcSpan' :: SrcSpan -> Bool
isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
isGoodSrcSpan' (UnhelpfulSpan _) = False

isGoodTickSrcSpan :: SrcSpan -> TM Bool
isGoodTickSrcSpan pos = do
1008
  file_name <- getFileName
1009
1010
1011
1012
1013
1014
1015
1016
1017
  tickish <- tickishType `liftM` getEnv
  let need_same_file = tickSameFileOnly tickish
      same_file      = Just file_name == srcSpanFileName_maybe pos
  return (isGoodSrcSpan' pos && (not need_same_file || same_file))

ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
ifGoodTickSrcSpan pos then_code else_code = do
  good <- isGoodTickSrcSpan pos
  if good then then_code else else_code
1018

1019
1020
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
1021
  = TM $ \ env st ->
1022
                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
1023
                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
1024
  where occs = [ nameOccName (idName id) | id <- new_ids ]
andy@galois.com's avatar
andy@galois.com committed
1025

1026
isBlackListed :: SrcSpan -> TM Bool
1027
1028
1029
1030
isBlackListed pos = TM $ \ env st ->
              case Map.lookup pos (blackList env) of
                Nothing -> (False,noFVs,st)
                Just () -> (True,noFVs,st)
1031

andy@galois.com's avatar
andy@galois.com committed
1032
-- the tick application inherits the source position of its
1033
-- expression argument to support nested box allocations
1034
1035
allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
             -> TM (LHsExpr Id)
1036
1037
allocTickBox boxLabel countEntries topOnly pos m =
  ifGoodTickSrcSpan pos (do
1038
1039
1040
1041
    (fvs, e) <- getFreeVars m
    env <- getEnv
    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
    return (L pos (HsTick tickish (L pos e)))
1042
1043
1044
1045
  ) (do
    e <- m
    return (L pos e)
  )
1046
1047

-- the tick application inherits the source position of its
1048
-- expression argument to support nested box allocations
1049
1050
allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
              -> TM (Maybe (Tickish Id))
1051
1052
allocATickBox boxLabel countEntries topOnly  pos fvs =
  ifGoodTickSrcSpan pos (do
1053
1054
1055
1056
1057
1058
1059
    let
      mydecl_path = case boxLabel of
                      TopLevelBox x -> x
                      LocalBox xs  -> xs
                      _ -> panic "allocATickBox"
    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
    return (Just tickish)
1060
  ) (return Nothing)
1061
1062
1063
1064
1065


mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
          -> TM (Tickish Id)
mkTickish boxLabel countEntries topOnly pos fvs decl_path =
Ian Lynagh's avatar
Ian Lynagh committed
1066
  TM $ \ env st ->
1067
    let c = tickBoxCount st
1068
1069
1070
1071
1072
1073
1074
        ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs
            -- unlifted types cause two problems here:
            --   * we can't bind them  at the GHCi prompt
            --     (bindLocalsAtBreakpoint already fliters them out),
            --   * the simplifier might try to substitute a literal for
            --     the Id, and we can't handle that.

1075
        mes = mixEntries st
1076
1077
1078
1079
1080
        me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)

        cc_name | topOnly   = head decl_path
                | otherwise = concat (intersperse "." decl_path)

1081
        cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
1082

1083
1084
1085
        dflags = tte_dflags env

        count = countEntries && dopt Opt_ProfCountEntries dflags
1086

1087
1088
1089
1090
        tickish = case tickishType env of
          HpcTicks    -> HpcTick (this_mod env) c
          ProfNotes   -> ProfNote cc count True{-scopes-}
          Breakpoints -> Breakpoint c ids
1091
    in
1092
    ( tickish
1093
1094
1095
    , fvs
    , st {tickBoxCount=c+1,mixEntries=me:mes}
    )
andy@galois.com's avatar
andy@galois.com committed
1096
1097


1098
1099
allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
                -> TM (LHsExpr Id)
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
allocBinTickBox boxLabel pos m = do
  env <- getEnv
  case tickishType env of
    HpcTicks -> do e <- liftM (L pos) m
                   ifGoodTickSrcSpan pos
                     (mkBinTickBoxHpc boxLabel pos e)
                     (return e)
    _other   -> allocTickBox (ExpBox False) False False pos m

mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id
                -> TM (LHsExpr Id)
mkBinTickBoxHpc boxLabel pos e =
Ian Lynagh's avatar
Ian Lynagh committed
1112
1113
1114
1115
 TM $ \ env st ->
  let meT = (pos,declPath env, [],boxLabel True)
      meF = (pos,declPath env, [],boxLabel False)
      meE = (pos,declPath env, [],ExpBox False)
andy@galois.com's avatar
andy@galois.com committed
1116
1117
      c = tickBoxCount st
      mes = mixEntries st
1118
  in
1119
             ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e
1120
1121
1122
           -- notice that F and T are reversed,
           -- because we are building the list in
           -- reverse...
1123
1124
             , noFVs
             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
1125
             )
1126
1127

mkHpcPos :: SrcSpan -> HpcPos
Ian Lynagh's avatar
Ian Lynagh committed
1128
1129
1130
1131
mkHpcPos pos@(RealSrcSpan s)
   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
                                    srcSpanStartCol s,
                                    srcSpanEndLine s,
1132
1133
1134
1135
1136
1137
                                    srcSpanEndCol s - 1)
                              -- the end column of a SrcSpan is one
                              -- greater than the last column of the
                              -- span (see SrcLoc), whereas HPC
                              -- expects to the column range to be
                              -- inclusive, hence we subtract one above.
Ian Lynagh's avatar
Ian Lynagh committed
1138
mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
andy@galois.com's avatar
andy@galois.com committed
1139

1140
hpcSrcSpan :: SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
1141
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
andy@galois.com's avatar
andy@galois.com committed
1142
1143
1144
\end{code}


1145
1146
1147
1148
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
  where
1149
        matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
1150
1151
1152
\end{code}


andy@galois.com's avatar
andy@galois.com committed
1153
\begin{code}
1154
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
1155

1156
-- For the hash value, we hash everything: the file name,
1157
1158
1159
1160
1161
--  the timestamp of the original source file, the tab stop,
--  and the mix entries. We cheat, and hash the show'd string.
-- This hash only has to be hashed at Mix creation time,
-- and is for sanity checking only.

1162
mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
1163
mixHash file tm tabstop entries = fromIntegral $ hashString
1164
        (show $ Mix file tm 0 tabstop entries)
andy@galois.com's avatar
andy@galois.com committed
1165
\end{code}
1166
1167

%************************************************************************
1168
%*                                                                      *
1169
%*              initialisation