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