d3fbe4cf4714365f20960da37bf6015507369114
[ghc.git] / compiler / deSugar / Coverage.lhs
1 %
2 % (c) Galois, 2006
3 % (c) University of Glasgow, 2007
4 %
5 \begin{code}
6 module Coverage (addTicksToBinds, hpcInitCode) where
7
8 import Type
9 import HsSyn
10 import Module
11 import Outputable
12 import DynFlags
13 import Control.Monad
14 import SrcLoc
15 import ErrUtils
16 import NameSet hiding (FreeVars)
17 import Name
18 import Bag
19 import CostCentre
20 import CoreSyn
21 import Id
22 import VarSet
23 import Data.List
24 import FastString
25 import HscTypes
26 import StaticFlags
27 import TyCon
28 import Unique
29 import BasicTypes
30 import MonadUtils
31 import Maybes
32 import CLabel
33 import Util
34
35 import Data.Array
36 import Data.Time
37 import System.Directory
38
39 import Trace.Hpc.Mix
40 import Trace.Hpc.Util
41
42 import BreakArray
43 import Data.Map (Map)
44 import qualified Data.Map as Map
45 \end{code}
46
47
48 %************************************************************************
49 %*                                                                      *
50 %*              The main function: addTicksToBinds
51 %*                                                                      *
52 %************************************************************************
53
54 \begin{code}
55 addTicksToBinds
56         :: DynFlags
57         -> Module
58         -> ModLocation          -- ... off the current module
59         -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
60                                 -- isExportedId doesn't work yet (the desugarer
61                                 -- hasn't set it), so we have to work from this set.
62         -> [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  case ml_hs_file mod_loc of
69    Nothing        -> return (binds, emptyHpcInfo False, emptyModBreaks)
70    Just orig_file -> do
71
72      if "boot" `isSuffixOf` orig_file
73          then return (binds, emptyHpcInfo False, emptyModBreaks)
74          else do
75
76      let  orig_file2 = guessSourceFile binds orig_file
77
78           (binds1,_,st)
79                  = unTM (addTickLHsBinds binds)
80                    (TTE
81                       { fileName     = mkFastString orig_file2
82                       , declPath     = []
83                       , tte_dflags   = dflags
84                       , exports      = exports
85                       , inlines      = emptyVarSet
86                       , inScope      = emptyVarSet
87                       , blackList    = Map.fromList
88                                           [ (getSrcSpan (tyConName tyCon),())
89                                           | tyCon <- tyCons ]
90                       , density      = mkDensity dflags
91                       , this_mod     = mod
92                        })
93                    (TT
94                       { tickBoxCount = 0
95                       , mixEntries   = []
96                       })
97
98      let entries = reverse $ mixEntries st
99
100      let count = tickBoxCount st
101      hashNo <- writeMixEntries dflags mod count entries orig_file2
102      modBreaks <- mkModBreaks count entries
103
104      doIfSet_dyn dflags Opt_D_dump_ticked $
105          log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
106              (pprLHsBinds binds1)
107
108      return (binds1, HpcInfo count hashNo, modBreaks)
109
110
111 guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
112 guessSourceFile binds orig_file =
113      -- Try look for a file generated from a .hsc file to a
114      -- .hs file, by peeking ahead.
115      let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
116                                  srcSpanFileName_maybe pos : rest) [] binds
117      in
118      case top_pos of
119         (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
120                       -> unpackFS file_name
121         _ -> orig_file
122
123
124 mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks
125 mkModBreaks count entries = do
126   breakArray <- newBreakArray $ length entries
127   let
128          locsTicks = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
129          varsTicks = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
130          declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
131          modBreaks = emptyModBreaks
132                      { modBreaks_flags = breakArray
133                      , modBreaks_locs  = locsTicks
134                      , modBreaks_vars  = varsTicks
135                      , modBreaks_decls = declsTicks
136                      }
137   --
138   return modBreaks
139
140
141 writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
142 writeMixEntries dflags mod count entries filename
143   | not opt_Hpc = return 0
144   | otherwise   = do
145         let
146             hpc_dir = hpcDir dflags
147             mod_name = moduleNameString (moduleName mod)
148
149             hpc_mod_dir
150               | modulePackageId mod == mainPackageId  = hpc_dir
151               | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
152
153             tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
154
155         createDirectoryIfMissing True hpc_mod_dir
156         modTime <- getModificationUTCTime filename
157         let entries' = [ (hpcPos, box)
158                        | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
159         when (length entries' /= count) $ do
160           panic "the number of .mix entries are inconsistent"
161         let hashNo = mixHash filename modTime tabStop entries'
162         mixCreate hpc_mod_dir mod_name
163                        $ Mix filename modTime (toHash hashNo) tabStop entries'
164         return hashNo
165
166
167 -- -----------------------------------------------------------------------------
168 -- TickDensity: where to insert ticks
169
170 data TickDensity
171   = TickForCoverage       -- for Hpc
172   | TickForBreakPoints    -- for GHCi
173   | TickAllFunctions      -- for -prof-auto-all
174   | TickTopFunctions      -- for -prof-auto-top
175   | TickExportedFunctions -- for -prof-auto-exported
176   | TickCallSites         -- for stack tracing
177   deriving Eq
178
179 mkDensity :: DynFlags -> TickDensity
180 mkDensity dflags
181   | opt_Hpc                              = TickForCoverage
182   | HscInterpreted  <- hscTarget dflags  = TickForBreakPoints
183   | ProfAutoAll     <- profAuto dflags   = TickAllFunctions
184   | ProfAutoTop     <- profAuto dflags   = TickTopFunctions
185   | ProfAutoExports <- profAuto dflags   = TickExportedFunctions
186   | ProfAutoCalls   <- profAuto dflags   = TickCallSites
187   | otherwise = panic "desnity"
188   -- ToDo: -fhpc is taking priority over -fprof-auto here.  It seems
189   -- that coverage works perfectly well with profiling, but you don't
190   -- get any auto-generated SCCs.  It would make perfect sense to
191   -- allow both of them, and indeed to combine some of the other flags
192   -- (-fprof-auto-calls -fprof-auto-top, for example)
193
194 -- | Decide whether to add a tick to a binding or not.
195 shouldTickBind  :: TickDensity
196                 -> Bool         -- top level?
197                 -> Bool         -- exported?
198                 -> Bool         -- simple pat bind?
199                 -> Bool         -- INLINE pragma?
200                 -> Bool
201
202 shouldTickBind density top_lev exported simple_pat inline
203  = case density of
204       TickForBreakPoints    -> not simple_pat
205         -- we never add breakpoints to simple pattern bindings
206         -- (there's always a tick on the rhs anyway).
207       TickAllFunctions      -> not inline
208       TickTopFunctions      -> top_lev && not inline
209       TickExportedFunctions -> exported && not inline
210       TickForCoverage       -> True
211       TickCallSites         -> False
212
213 shouldTickPatBind :: TickDensity -> Bool -> Bool
214 shouldTickPatBind density top_lev
215   = case density of
216       TickForBreakPoints    -> False
217       TickAllFunctions      -> True
218       TickTopFunctions      -> top_lev
219       TickExportedFunctions -> False
220       TickForCoverage       -> False
221       TickCallSites         -> False
222
223 -- -----------------------------------------------------------------------------
224 -- Adding ticks to bindings
225
226 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
227 addTickLHsBinds binds = mapBagM addTickLHsBind binds
228
229 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
230 addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
231                                        abs_exports = abs_exports })) = do
232   withEnv add_exports $ do
233   withEnv add_inlines $ do
234   binds' <- addTickLHsBinds binds
235   return $ L pos $ bind { abs_binds = binds' }
236  where
237    -- in AbsBinds, the Id on each binding is not the actual top-level
238    -- Id that we are defining, they are related by the abs_exports
239    -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
240    -- to add the local Ids to the set of exported Names so that we know to
241    -- tick the right bindings.
242    add_exports env =
243      env{ exports = exports env `addListToNameSet`
244                       [ idName mid
245                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
246                       , idName pid `elemNameSet` (exports env) ] }
247
248    add_inlines env =
249      env{ inlines = inlines env `extendVarSetList`
250                       [ mid
251                       | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
252                       , isAnyInlinePragma (idInlinePragma pid) ] }
253
254
255 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
256   env <- getEnv
257   let dflags = tte_dflags env
258   let name = getOccString id
259   decl_path <- getPathEntry
260   density <- getDensity
261
262   inline_ids <- liftM inlines getEnv
263   let inline   = isAnyInlinePragma (idInlinePragma id)
264                  || id `elemVarSet` inline_ids
265
266   -- See Note [inline sccs]
267   if inline && dopt Opt_SccProfilingOn dflags then return (L pos funBind) else do
268
269   (fvs, (MatchGroup matches' ty)) <-
270         getFreeVars $
271         addPathEntry name $
272         addTickMatchGroup False (fun_matches funBind)
273
274   blackListed <- isBlackListed pos
275   exported_names <- liftM exports getEnv
276
277   -- We don't want to generate code for blacklisted positions
278   -- We don't want redundant ticks on simple pattern bindings
279   -- We don't want to tick non-exported bindings in TickExportedFunctions
280   let simple = isSimplePatBind funBind
281       toplev = null decl_path
282       exported = idName id `elemNameSet` exported_names
283
284   tick <- if not blackListed &&
285                shouldTickBind density toplev exported simple inline
286              then
287                 bindTick density name pos fvs
288              else
289                 return Nothing
290
291   return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
292                            , fun_tick = tick }
293
294    where
295    -- a binding is a simple pattern binding if it is a funbind with zero patterns
296    isSimplePatBind :: HsBind a -> Bool
297    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
298
299 -- TODO: Revisit this
300 addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do
301   let name = "(...)"
302   (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
303
304   density <- getDensity
305   decl_path <- getPathEntry
306   let top_lev = null decl_path
307   let add_ticks = shouldTickPatBind density top_lev
308
309   tickish <- if add_ticks
310                 then bindTick density name pos fvs
311                 else return Nothing
312
313   let patvars = map getOccString (collectPatBinders lhs)
314   patvar_ticks <- if add_ticks
315                      then mapM (\v -> bindTick density v pos fvs) patvars
316                      else return []
317
318   return $ L pos $ pat { pat_rhs = rhs',
319                          pat_ticks = (tickish, patvar_ticks)}
320
321 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
322 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
323
324
325 bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
326 bindTick density name pos fvs = do
327   decl_path <- getPathEntry
328   let
329       toplev        = null decl_path
330       count_entries = toplev || density == TickAllFunctions
331       top_only      = density /= TickAllFunctions
332       box_label     = if toplev then TopLevelBox [name]
333                                 else LocalBox (decl_path ++ [name])
334   --
335   allocATickBox box_label count_entries top_only pos fvs
336
337
338 -- Note [inline sccs]
339 --
340 -- It should be reasonable to add ticks to INLINE functions; however
341 -- currently this tickles a bug later on because the SCCfinal pass
342 -- does not look inside unfoldings to find CostCentres.  It would be
343 -- difficult to fix that, because SCCfinal currently works on STG and
344 -- not Core (and since it also generates CostCentres for CAFs,
345 -- changing this would be difficult too).
346 --
347 -- Another reason not to add ticks to INLINE functions is that this
348 -- sometimes handy for avoiding adding a tick to a particular function
349 -- (see #6131)
350 --
351 -- So for now we do not add any ticks to INLINE functions at all.
352
353 -- -----------------------------------------------------------------------------
354 -- Decorate an LHsExpr with ticks
355
356 -- selectively add ticks to interesting expressions
357 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
358 addTickLHsExpr e@(L pos e0) = do
359   d <- getDensity
360   case d of
361     TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
362     TickForCoverage    -> tick_it
363     TickCallSites      | isCallSite e0      -> tick_it
364     _other             -> dont_tick_it
365  where
366    tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
367    dont_tick_it = addTickLHsExprNever e
368
369 -- Add a tick to an expression which is the RHS of an equation or a binding.
370 -- We always consider these to be breakpoints, unless the expression is a 'let'
371 -- (because the body will definitely have a tick somewhere).  ToDo: perhaps
372 -- we should treat 'case' and 'if' the same way?
373 addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)
374 addTickLHsExprRHS e@(L pos e0) = do
375   d <- getDensity
376   case d of
377      TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
378                         | otherwise     -> tick_it
379      TickForCoverage -> tick_it
380      TickCallSites   | isCallSite e0 -> tick_it
381      _other          -> dont_tick_it
382  where
383    tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
384    dont_tick_it = addTickLHsExprNever e
385
386 -- The inner expression of an evaluation context:
387 --    let binds in [], ( [] )
388 -- we never tick these if we're doing HPC, but otherwise
389 -- we treat it like an ordinary expression.
390 addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)
391 addTickLHsExprEvalInner e = do
392    d <- getDensity
393    case d of
394      TickForCoverage -> addTickLHsExprNever e
395      _otherwise      -> addTickLHsExpr e
396
397 -- | A let body is treated differently from addTickLHsExprEvalInner
398 -- above with TickForBreakPoints, because for breakpoints we always
399 -- want to tick the body, even if it is not a redex.  See test
400 -- break012.  This gives the user the opportunity to inspect the
401 -- values of the let-bound variables.
402 addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)
403 addTickLHsExprLetBody e@(L pos e0) = do
404   d <- getDensity
405   case d of
406      TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
407                         | otherwise     -> tick_it
408      _other -> addTickLHsExprEvalInner e
409  where
410    tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
411    dont_tick_it = addTickLHsExprNever e
412
413 -- version of addTick that does not actually add a tick,
414 -- because the scope of this tick is completely subsumed by
415 -- another.
416 addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
417 addTickLHsExprNever (L pos e0) = do
418     e1 <- addTickHsExpr e0
419     return $ L pos e1
420
421 -- general heuristic: expressions which do not denote values are good break points
422 isGoodBreakExpr :: HsExpr Id -> Bool
423 isGoodBreakExpr (HsApp {})     = True
424 isGoodBreakExpr (OpApp {})     = True
425 isGoodBreakExpr (NegApp {})    = True
426 isGoodBreakExpr (HsIf {})      = True
427 isGoodBreakExpr (HsMultiIf {}) = True
428 isGoodBreakExpr (HsCase {})    = True
429 isGoodBreakExpr (RecordCon {}) = True
430 isGoodBreakExpr (RecordUpd {}) = True
431 isGoodBreakExpr (ArithSeq {})  = True
432 isGoodBreakExpr (PArrSeq {})   = True
433 isGoodBreakExpr _other         = False
434
435 isCallSite :: HsExpr Id -> Bool
436 isCallSite HsApp{}  = True
437 isCallSite OpApp{}  = True
438 isCallSite _ = False
439
440 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
441 addTickLHsExprOptAlt oneOfMany (L pos e0)
442   = ifDensity TickForCoverage
443         (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
444         (addTickLHsExpr (L pos e0))
445
446 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
447 addBinTickLHsExpr boxLabel (L pos e0)
448   = ifDensity TickForCoverage
449         (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
450         (addTickLHsExpr (L pos e0))
451
452
453 -- -----------------------------------------------------------------------------
454 -- Decoarate an HsExpr with ticks
455
456 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
457 addTickHsExpr e@(HsVar id) = do freeVar id; return e
458 addTickHsExpr e@(HsIPVar _) = return e
459 addTickHsExpr e@(HsOverLit _) = return e
460 addTickHsExpr e@(HsLit _) = return e
461 addTickHsExpr (HsLam matchgroup) =
462         liftM HsLam (addTickMatchGroup True matchgroup)
463 addTickHsExpr (HsLamCase ty mgs) =
464         liftM (HsLamCase ty) (addTickMatchGroup True mgs)
465 addTickHsExpr (HsApp e1 e2) =
466         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
467 addTickHsExpr (OpApp e1 e2 fix e3) =
468         liftM4 OpApp
469                 (addTickLHsExpr e1)
470                 (addTickLHsExprNever e2)
471                 (return fix)
472                 (addTickLHsExpr e3)
473 addTickHsExpr (NegApp e neg) =
474         liftM2 NegApp
475                 (addTickLHsExpr e)
476                 (addTickSyntaxExpr hpcSrcSpan neg)
477 addTickHsExpr (HsPar e) =
478         liftM HsPar (addTickLHsExprEvalInner e)
479 addTickHsExpr (SectionL e1 e2) =
480         liftM2 SectionL
481                 (addTickLHsExpr e1)
482                 (addTickLHsExprNever e2)
483 addTickHsExpr (SectionR e1 e2) =
484         liftM2 SectionR
485                 (addTickLHsExprNever e1)
486                 (addTickLHsExpr e2)
487 addTickHsExpr (ExplicitTuple es boxity) =
488         liftM2 ExplicitTuple
489                 (mapM addTickTupArg es)
490                 (return boxity)
491 addTickHsExpr (HsCase e mgs) =
492         liftM2 HsCase
493                 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
494                                    -- be evaluated.
495                 (addTickMatchGroup False mgs)
496 addTickHsExpr (HsIf cnd e1 e2 e3) =
497         liftM3 (HsIf cnd)
498                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
499                 (addTickLHsExprOptAlt True e2)
500                 (addTickLHsExprOptAlt True e3)
501 addTickHsExpr (HsMultiIf ty alts)
502   = do { let isOneOfMany = case alts of [_] -> False; _ -> True
503        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
504        ; return $ HsMultiIf ty alts' }
505 addTickHsExpr (HsLet binds e) =
506         bindLocals (collectLocalBinders binds) $
507         liftM2 HsLet
508                 (addTickHsLocalBinds binds) -- to think about: !patterns.
509                 (addTickLHsExprLetBody e)
510 addTickHsExpr (HsDo cxt stmts srcloc)
511   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
512        ; return (HsDo cxt stmts' srcloc) }
513   where
514         forQual = case cxt of
515                     ListComp -> Just $ BinBox QualBinBox
516                     _        -> Nothing
517 addTickHsExpr (ExplicitList ty es) =
518         liftM2 ExplicitList
519                 (return ty)
520                 (mapM (addTickLHsExpr) es)
521 addTickHsExpr (ExplicitPArr ty es) =
522         liftM2 ExplicitPArr
523                 (return ty)
524                 (mapM (addTickLHsExpr) es)
525 addTickHsExpr (RecordCon id ty rec_binds) =
526         liftM3 RecordCon
527                 (return id)
528                 (return ty)
529                 (addTickHsRecordBinds rec_binds)
530 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
531         liftM5 RecordUpd
532                 (addTickLHsExpr e)
533                 (addTickHsRecordBinds rec_binds)
534                 (return cons) (return tys1) (return tys2)
535
536 addTickHsExpr (ExprWithTySigOut e ty) =
537         liftM2 ExprWithTySigOut
538                 (addTickLHsExprNever e) -- No need to tick the inner expression
539                                     -- for expressions with signatures
540                 (return ty)
541 addTickHsExpr (ArithSeq  ty arith_seq) =
542         liftM2 ArithSeq
543                 (return ty)
544                 (addTickArithSeqInfo arith_seq)
545 addTickHsExpr (HsTickPragma _ (L pos e0)) = do
546     e2 <- allocTickBox (ExpBox False) False False pos $
547                 addTickHsExpr e0
548     return $ unLoc e2
549 addTickHsExpr (PArrSeq   ty arith_seq) =
550         liftM2 PArrSeq
551                 (return ty)
552                 (addTickArithSeqInfo arith_seq)
553 addTickHsExpr (HsSCC nm e) =
554         liftM2 HsSCC
555                 (return nm)
556                 (addTickLHsExpr e)
557 addTickHsExpr (HsCoreAnn nm e) =
558         liftM2 HsCoreAnn
559                 (return nm)
560                 (addTickLHsExpr e)
561 addTickHsExpr e@(HsBracket     {}) = return e
562 addTickHsExpr e@(HsBracketOut  {}) = return e
563 addTickHsExpr e@(HsSpliceE  {}) = return e
564 addTickHsExpr (HsProc pat cmdtop) =
565         liftM2 HsProc
566                 (addTickLPat pat)
567                 (liftL (addTickHsCmdTop) cmdtop)
568 addTickHsExpr (HsWrap w e) =
569         liftM2 HsWrap
570                 (return w)
571                 (addTickHsExpr e)       -- explicitly no tick on inside
572
573 addTickHsExpr e@(HsType _) = return e
574
575 -- Others dhould never happen in expression content.
576 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
577
578 addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
579 addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
580 addTickTupArg (Missing ty) = return (Missing ty)
581
582 addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
583 addTickMatchGroup is_lam (MatchGroup matches ty) = do
584   let isOneOfMany = matchesOneOfMany matches
585   matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
586   return $ MatchGroup matches' ty
587
588 addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
589 addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
590   bindLocals (collectPatsBinders pats) $ do
591     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
592     return $ Match pats opSig gRHSs'
593
594 addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
595 addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
596   bindLocals binders $ do
597     local_binds' <- addTickHsLocalBinds local_binds
598     guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
599     return $ GRHSs guarded' local_binds'
600   where
601     binders = collectLocalBinders local_binds
602
603 addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
604 addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
605   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
606                         (addTickGRHSBody isOneOfMany isLambda expr)
607   return $ GRHS stmts' expr'
608
609 addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)
610 addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
611   d <- getDensity
612   case d of
613     TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
614     TickAllFunctions | isLambda ->
615        addPathEntry "\\" $
616          allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
617            addTickHsExpr e0
618     _otherwise ->
619        addTickLHsExprRHS expr
620
621 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
622 addTickLStmts isGuard stmts = do
623   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
624   return stmts
625
626 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
627                -> TM ([LStmt Id], a)
628 addTickLStmts' isGuard lstmts res
629   = bindLocals (collectLStmtsBinders lstmts) $
630     do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
631        ; a <- res
632        ; return (lstmts', a) }
633
634 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
635 addTickStmt _isGuard (LastStmt e ret) = do
636         liftM2 LastStmt
637                 (addTickLHsExpr e)
638                 (addTickSyntaxExpr hpcSrcSpan ret)
639 addTickStmt _isGuard (BindStmt pat e bind fail) = do
640         liftM4 BindStmt
641                 (addTickLPat pat)
642                 (addTickLHsExprRHS e)
643                 (addTickSyntaxExpr hpcSrcSpan bind)
644                 (addTickSyntaxExpr hpcSrcSpan fail)
645 addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
646         liftM4 ExprStmt
647                 (addTick isGuard e)
648                 (addTickSyntaxExpr hpcSrcSpan bind')
649                 (addTickSyntaxExpr hpcSrcSpan guard')
650                 (return ty)
651 addTickStmt _isGuard (LetStmt binds) = do
652         liftM LetStmt
653                 (addTickHsLocalBinds binds)
654 addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
655     liftM3 ParStmt
656         (mapM (addTickStmtAndBinders isGuard) pairs)
657         (addTickSyntaxExpr hpcSrcSpan mzipExpr)
658         (addTickSyntaxExpr hpcSrcSpan bindExpr)
659
660 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
661                                     , trS_by = by, trS_using = using
662                                     , trS_ret = returnExpr, trS_bind = bindExpr
663                                     , trS_fmap = liftMExpr }) = do
664     t_s <- addTickLStmts isGuard stmts
665     t_y <- fmapMaybeM  addTickLHsExprRHS by
666     t_u <- addTickLHsExprRHS using
667     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
668     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
669     t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
670     return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
671                   , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
672
673 addTickStmt isGuard stmt@(RecStmt {})
674   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
675        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
676        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
677        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
678        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
679                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
680
681 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
682 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
683                   | otherwise          = addTickLHsExprRHS e
684
685 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
686                       -> TM (ParStmtBlock Id Id)
687 addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
688     liftM3 ParStmtBlock
689         (addTickLStmts isGuard stmts)
690         (return ids)
691         (addTickSyntaxExpr hpcSrcSpan returnExpr)
692
693 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
694 addTickHsLocalBinds (HsValBinds binds) =
695         liftM HsValBinds
696                 (addTickHsValBinds binds)
697 addTickHsLocalBinds (HsIPBinds binds)  =
698         liftM HsIPBinds
699                 (addTickHsIPBinds binds)
700 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
701
702 addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
703 addTickHsValBinds (ValBindsOut binds sigs) =
704         liftM2 ValBindsOut
705                 (mapM (\ (rec,binds') ->
706                                 liftM2 (,)
707                                         (return rec)
708                                         (addTickLHsBinds binds'))
709                         binds)
710                 (return sigs)
711 addTickHsValBinds _ = panic "addTickHsValBinds"
712
713 addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
714 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
715         liftM2 IPBinds
716                 (mapM (liftL (addTickIPBind)) ipbinds)
717                 (return dictbinds)
718
719 addTickIPBind :: IPBind Id -> TM (IPBind Id)
720 addTickIPBind (IPBind nm e) =
721         liftM2 IPBind
722                 (return nm)
723                 (addTickLHsExpr e)
724
725 -- There is no location here, so we might need to use a context location??
726 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
727 addTickSyntaxExpr pos x = do
728         L _ x' <- addTickLHsExpr (L pos x)
729         return $ x'
730 -- we do not walk into patterns.
731 addTickLPat :: LPat Id -> TM (LPat Id)
732 addTickLPat pat = return pat
733
734 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
735 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
736         liftM4 HsCmdTop
737                 (addTickLHsCmd cmd)
738                 (return tys)
739                 (return ty)
740                 (return syntaxtable)
741
742 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
743 addTickLHsCmd (L pos c0) = do
744         c1 <- addTickHsCmd c0
745         return $ L pos c1
746
747 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
748 addTickHsCmd (HsLam matchgroup) =
749         liftM HsLam (addTickCmdMatchGroup matchgroup)
750 addTickHsCmd (HsApp c e) =
751         liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
752 addTickHsCmd (OpApp e1 c2 fix c3) =
753         liftM4 OpApp
754                 (addTickLHsExpr e1)
755                 (addTickLHsCmd c2)
756                 (return fix)
757                 (addTickLHsCmd c3)
758 addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
759 addTickHsCmd (HsCase e mgs) =
760         liftM2 HsCase
761                 (addTickLHsExpr e)
762                 (addTickCmdMatchGroup mgs)
763 addTickHsCmd (HsIf cnd e1 c2 c3) =
764         liftM3 (HsIf cnd)
765                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
766                 (addTickLHsCmd c2)
767                 (addTickLHsCmd c3)
768 addTickHsCmd (HsLet binds c) =
769         bindLocals (collectLocalBinders binds) $
770         liftM2 HsLet
771                 (addTickHsLocalBinds binds) -- to think about: !patterns.
772                 (addTickLHsCmd c)
773 addTickHsCmd (HsDo cxt stmts srcloc)
774   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
775        ; return (HsDo cxt stmts' srcloc) }
776
777 addTickHsCmd (HsArrApp   e1 e2 ty1 arr_ty lr) =
778         liftM5 HsArrApp
779                (addTickLHsExpr e1)
780                (addTickLHsExpr e2)
781                (return ty1)
782                (return arr_ty)
783                (return lr)
784 addTickHsCmd (HsArrForm e fix cmdtop) =
785         liftM3 HsArrForm
786                (addTickLHsExpr e)
787                (return fix)
788                (mapM (liftL (addTickHsCmdTop)) cmdtop)
789
790 -- Others should never happen in a command context.
791 addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
792
793 addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
794 addTickCmdMatchGroup (MatchGroup matches ty) = do
795   matches' <- mapM (liftL addTickCmdMatch) matches
796   return $ MatchGroup matches' ty
797
798 addTickCmdMatch :: Match Id -> TM (Match Id)
799 addTickCmdMatch (Match pats opSig gRHSs) =
800   bindLocals (collectPatsBinders pats) $ do
801     gRHSs' <- addTickCmdGRHSs gRHSs
802     return $ Match pats opSig gRHSs'
803
804 addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
805 addTickCmdGRHSs (GRHSs guarded local_binds) = do
806   bindLocals binders $ do
807     local_binds' <- addTickHsLocalBinds local_binds
808     guarded' <- mapM (liftL addTickCmdGRHS) guarded
809     return $ GRHSs guarded' local_binds'
810   where
811     binders = collectLocalBinders local_binds
812
813 addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
814 -- The *guards* are *not* Cmds, although the body is
815 -- C.f. addTickGRHS for the BinBox stuff
816 addTickCmdGRHS (GRHS stmts cmd)
817   = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
818                                    stmts (addTickLHsCmd cmd)
819        ; return $ GRHS stmts' expr' }
820
821 addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
822 addTickLCmdStmts stmts = do
823   (stmts, _) <- addTickLCmdStmts' stmts (return ())
824   return stmts
825
826 addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
827 addTickLCmdStmts' lstmts res
828   = bindLocals binders $ do
829         lstmts' <- mapM (liftL addTickCmdStmt) lstmts
830         a <- res
831         return (lstmts', a)
832   where
833         binders = collectLStmtsBinders lstmts
834
835 addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
836 addTickCmdStmt (BindStmt pat c bind fail) = do
837         liftM4 BindStmt
838                 (addTickLPat pat)
839                 (addTickLHsCmd c)
840                 (return bind)
841                 (return fail)
842 addTickCmdStmt (LastStmt c ret) = do
843         liftM2 LastStmt
844                 (addTickLHsCmd c)
845                 (addTickSyntaxExpr hpcSrcSpan ret)
846 addTickCmdStmt (ExprStmt c bind' guard' ty) = do
847         liftM4 ExprStmt
848                 (addTickLHsCmd c)
849                 (addTickSyntaxExpr hpcSrcSpan bind')
850                 (addTickSyntaxExpr hpcSrcSpan guard')
851                 (return ty)
852 addTickCmdStmt (LetStmt binds) = do
853         liftM LetStmt
854                 (addTickHsLocalBinds binds)
855 addTickCmdStmt stmt@(RecStmt {})
856   = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
857        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
858        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
859        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
860        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
861                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
862
863 -- Others should never happen in a command context.
864 addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
865
866 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
867 addTickHsRecordBinds (HsRecFields fields dd)
868   = do  { fields' <- mapM process fields
869         ; return (HsRecFields fields' dd) }
870   where
871     process (HsRecField ids expr doc)
872         = do { expr' <- addTickLHsExpr expr
873              ; return (HsRecField ids expr' doc) }
874
875 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
876 addTickArithSeqInfo (From e1) =
877         liftM From
878                 (addTickLHsExpr e1)
879 addTickArithSeqInfo (FromThen e1 e2) =
880         liftM2 FromThen
881                 (addTickLHsExpr e1)
882                 (addTickLHsExpr e2)
883 addTickArithSeqInfo (FromTo e1 e2) =
884         liftM2 FromTo
885                 (addTickLHsExpr e1)
886                 (addTickLHsExpr e2)
887 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
888         liftM3 FromThenTo
889                 (addTickLHsExpr e1)
890                 (addTickLHsExpr e2)
891                 (addTickLHsExpr e3)
892
893 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
894 liftL f (L loc a) = do
895   a' <- f a
896   return $ L loc a'
897 \end{code}
898
899 \begin{code}
900 data TickTransState = TT { tickBoxCount:: Int
901                          , mixEntries  :: [MixEntry_]
902                          }
903
904 data TickTransEnv = TTE { fileName     :: FastString
905                         , density      :: TickDensity
906                         , tte_dflags   :: DynFlags
907                         , exports      :: NameSet
908                         , inlines      :: VarSet
909                         , declPath     :: [String]
910                         , inScope      :: VarSet
911                         , blackList    :: Map SrcSpan ()
912                         , this_mod     :: Module
913                         }
914
915 --      deriving Show
916
917 type FreeVars = OccEnv Id
918 noFVs :: FreeVars
919 noFVs = emptyOccEnv
920
921 -- Note [freevars]
922 --   For breakpoints we want to collect the free variables of an
923 --   expression for pinning on the HsTick.  We don't want to collect
924 --   *all* free variables though: in particular there's no point pinning
925 --   on free variables that are will otherwise be in scope at the GHCi
926 --   prompt, which means all top-level bindings.  Unfortunately detecting
927 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
928 --   bindings doesn't do it), so we keep track of a set of "in-scope"
929 --   variables in addition to the free variables, and the former is used
930 --   to filter additions to the latter.  This gives us complete control
931 --   over what free variables we track.
932
933 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
934         -- a combination of a state monad (TickTransState) and a writer
935         -- monad (FreeVars).
936
937 instance Monad TM where
938   return a = TM $ \ _env st -> (a,noFVs,st)
939   (TM m) >>= k = TM $ \ env st ->
940                                 case m env st of
941                                   (r1,fv1,st1) ->
942                                      case unTM (k r1) env st1 of
943                                        (r2,fv2,st2) ->
944                                           (r2, fv1 `plusOccEnv` fv2, st2)
945
946 -- getState :: TM TickTransState
947 -- getState = TM $ \ env st -> (st, noFVs, st)
948
949 -- setState :: (TickTransState -> TickTransState) -> TM ()
950 -- setState f = TM $ \ env st -> ((), noFVs, f st)
951
952 getEnv :: TM TickTransEnv
953 getEnv = TM $ \ env st -> (env, noFVs, st)
954
955 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
956 withEnv f (TM m) = TM $ \ env st ->
957                                  case m (f env) st of
958                                    (a, fvs, st') -> (a, fvs, st')
959
960 getDensity :: TM TickDensity
961 getDensity = TM $ \env st -> (density env, noFVs, st)
962
963 ifDensity :: TickDensity -> TM a -> TM a -> TM a
964 ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
965
966 getFreeVars :: TM a -> TM (FreeVars, a)
967 getFreeVars (TM m)
968   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
969
970 freeVar :: Id -> TM ()
971 freeVar id = TM $ \ env st ->
972                 if id `elemVarSet` inScope env
973                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
974                    else ((), noFVs, st)
975
976 addPathEntry :: String -> TM a -> TM a
977 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
978
979 getPathEntry :: TM [String]
980 getPathEntry = declPath `liftM` getEnv
981
982 getFileName :: TM FastString
983 getFileName = fileName `liftM` getEnv
984
985 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
986 sameFileName pos out_of_scope in_scope = do
987   file_name <- getFileName
988   case srcSpanFileName_maybe pos of
989     Just file_name2
990       | file_name == file_name2 -> in_scope
991     _ -> out_of_scope
992
993 bindLocals :: [Id] -> TM a -> TM a
994 bindLocals new_ids (TM m)
995   = TM $ \ env st ->
996                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
997                    (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
998   where occs = [ nameOccName (idName id) | id <- new_ids ]
999
1000 isBlackListed :: SrcSpan -> TM Bool
1001 isBlackListed pos = TM $ \ env st ->
1002               case Map.lookup pos (blackList env) of
1003                 Nothing -> (False,noFVs,st)
1004                 Just () -> (True,noFVs,st)
1005
1006 -- the tick application inherits the source position of its
1007 -- expression argument to support nested box allocations
1008 allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)
1009              -> TM (LHsExpr Id)
1010 allocTickBox boxLabel countEntries topOnly pos m | isGoodSrcSpan' pos =
1011   sameFileName pos (do e <- m; return (L pos e)) $ do
1012     (fvs, e) <- getFreeVars m
1013     env <- getEnv
1014     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
1015     return (L pos (HsTick tickish (L pos e)))
1016 allocTickBox _boxLabel _countEntries _topOnly pos m = do
1017   e <- m
1018   return (L pos e)
1019
1020
1021 -- the tick application inherits the source position of its
1022 -- expression argument to support nested box allocations
1023 allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
1024               -> TM (Maybe (Tickish Id))
1025 allocATickBox boxLabel countEntries topOnly  pos fvs | isGoodSrcSpan' pos =
1026   sameFileName pos (return Nothing) $ do
1027     let
1028       mydecl_path = case boxLabel of
1029                       TopLevelBox x -> x
1030                       LocalBox xs  -> xs
1031                       _ -> panic "allocATickBox"
1032     tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
1033     return (Just tickish)
1034 allocATickBox _boxLabel _countEntries _topOnly _pos _fvs =
1035   return Nothing
1036
1037
1038 mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
1039           -> TM (Tickish Id)
1040 mkTickish boxLabel countEntries topOnly pos fvs decl_path =
1041   TM $ \ env st ->
1042     let c = tickBoxCount st
1043         ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs
1044             -- unlifted types cause two problems here:
1045             --   * we can't bind them  at the GHCi prompt
1046             --     (bindLocalsAtBreakpoint already fliters them out),
1047             --   * the simplifier might try to substitute a literal for
1048             --     the Id, and we can't handle that.
1049
1050         mes = mixEntries st
1051         me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
1052
1053         cc_name | topOnly   = head decl_path
1054                 | otherwise = concat (intersperse "." decl_path)
1055
1056         cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
1057
1058         dflags = tte_dflags env
1059
1060         count = countEntries && dopt Opt_ProfCountEntries dflags
1061
1062         tickish
1063           | opt_Hpc                        = HpcTick (this_mod env) c
1064           | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-}
1065           | otherwise                      = Breakpoint c ids
1066     in
1067     ( tickish
1068     , fvs
1069     , st {tickBoxCount=c+1,mixEntries=me:mes}
1070     )
1071
1072
1073 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
1074                 -> TM (LHsExpr Id)
1075 allocBinTickBox boxLabel pos m
1076  | not opt_Hpc = allocTickBox (ExpBox False) False False pos m
1077  | isGoodSrcSpan' pos =
1078  do
1079  e <- m
1080  TM $ \ env st ->
1081   let meT = (pos,declPath env, [],boxLabel True)
1082       meF = (pos,declPath env, [],boxLabel False)
1083       meE = (pos,declPath env, [],ExpBox False)
1084       c = tickBoxCount st
1085       mes = mixEntries st
1086   in
1087              ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
1088            -- notice that F and T are reversed,
1089            -- because we are building the list in
1090            -- reverse...
1091              , noFVs
1092              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
1093              )
1094 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
1095
1096 isGoodSrcSpan' :: SrcSpan -> Bool
1097 isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
1098 isGoodSrcSpan' (UnhelpfulSpan _) = False
1099
1100 mkHpcPos :: SrcSpan -> HpcPos
1101 mkHpcPos pos@(RealSrcSpan s)
1102    | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
1103                                     srcSpanStartCol s,
1104                                     srcSpanEndLine s,
1105                                     srcSpanEndCol s - 1)
1106                               -- the end column of a SrcSpan is one
1107                               -- greater than the last column of the
1108                               -- span (see SrcLoc), whereas HPC
1109                               -- expects to the column range to be
1110                               -- inclusive, hence we subtract one above.
1111 mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
1112
1113 hpcSrcSpan :: SrcSpan
1114 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
1115 \end{code}
1116
1117
1118 \begin{code}
1119 matchesOneOfMany :: [LMatch Id] -> Bool
1120 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
1121   where
1122         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
1123 \end{code}
1124
1125
1126 \begin{code}
1127 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
1128
1129 -- For the hash value, we hash everything: the file name,
1130 --  the timestamp of the original source file, the tab stop,
1131 --  and the mix entries. We cheat, and hash the show'd string.
1132 -- This hash only has to be hashed at Mix creation time,
1133 -- and is for sanity checking only.
1134
1135 mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
1136 mixHash file tm tabstop entries = fromIntegral $ hashString
1137         (show $ Mix file tm 0 tabstop entries)
1138 \end{code}
1139
1140 %************************************************************************
1141 %*                                                                      *
1142 %*              initialisation
1143 %*                                                                      *
1144 %************************************************************************
1145
1146 Each module compiled with -fhpc declares an initialisation function of
1147 the form `hpc_init_<module>()`, which is emitted into the _stub.c file
1148 and annotated with __attribute__((constructor)) so that it gets
1149 executed at startup time.
1150
1151 The function's purpose is to call hs_hpc_module to register this
1152 module with the RTS, and it looks something like this:
1153
1154 static void hpc_init_Main(void) __attribute__((constructor));
1155 static void hpc_init_Main(void)
1156 {extern StgWord64 _hpc_tickboxes_Main_hpc[];
1157  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
1158
1159 \begin{code}
1160 hpcInitCode :: Module -> HpcInfo -> SDoc
1161 hpcInitCode _ (NoHpcInfo {}) = empty
1162 hpcInitCode this_mod (HpcInfo tickCount hashNo)
1163  = vcat
1164     [ text "static void hpc_init_" <> ppr this_mod
1165          <> text "(void) __attribute__((constructor));"
1166     , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
1167     , braces (vcat [
1168         ptext (sLit "extern StgWord64 ") <> tickboxes <>
1169                ptext (sLit "[]") <> semi,
1170         ptext (sLit "hs_hpc_module") <>
1171           parens (hcat (punctuate comma [
1172               doubleQuotes full_name_str,
1173               int tickCount, -- really StgWord32
1174               int hashNo,    -- really StgWord32
1175               tickboxes
1176             ])) <> semi
1177        ])
1178     ]
1179   where
1180     tickboxes = ppr (mkHpcTicksLabel $ this_mod)
1181
1182     module_name  = hcat (map (text.charToC) $
1183                          bytesFS (moduleNameFS (Module.moduleName this_mod)))
1184     package_name = hcat (map (text.charToC) $
1185                          bytesFS (packageIdFS  (modulePackageId this_mod)))
1186     full_name_str
1187        | modulePackageId this_mod == mainPackageId
1188        = module_name
1189        | otherwise
1190        = package_name <> char '/' <> module_name
1191 \end{code}