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