More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[ghc.git] / compiler / deSugar / Coverage.lhs
1 %
2 % (c) Galois, 2006
3 % (c) University of Glasgow, 2007
4 %
5 \section[Coverage]{@coverage@: the main function}
6
7 \begin{code}
8 module Coverage (addCoverageTicksToBinds, hpcInitCode) where
9
10 import HsSyn
11 import Module
12 import Outputable
13 import DynFlags
14 import Control.Monad
15 import SrcLoc
16 import ErrUtils
17 import Name
18 import Bag
19 import Id
20 import VarSet
21 import Data.List
22 import FastString
23 import HscTypes 
24 import Platform
25 import StaticFlags
26 import TyCon
27 import MonadUtils
28 import Maybes
29 import CLabel
30 import Util
31
32 import Data.Array
33 import System.Directory ( createDirectoryIfMissing )
34
35 import Trace.Hpc.Mix
36 import Trace.Hpc.Util
37
38 import BreakArray 
39 import Data.HashTable   ( hashString )
40 import Data.Map (Map)
41 import qualified Data.Map as Map
42 \end{code}
43
44
45 %************************************************************************
46 %*                                                                      *
47 %*              The main function: addCoverageTicksToBinds
48 %*                                                                      *
49 %************************************************************************
50
51 \begin{code}
52 addCoverageTicksToBinds
53         :: DynFlags
54         -> Module
55         -> ModLocation          -- of the current module
56         -> [TyCon]              -- type constructor in this module
57         -> LHsBinds Id
58         -> IO (LHsBinds Id, HpcInfo, ModBreaks)
59
60 addCoverageTicksToBinds dflags mod mod_loc tyCons binds = 
61  case ml_hs_file mod_loc of
62  Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
63  Just orig_file -> do
64
65   if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
66
67   -- Now, we try look for a file generated from a .hsc file to a .hs file, by peeking ahead.
68
69   let top_pos = catMaybes $ foldrBag (\ (L pos _) rest -> srcSpanFileName_maybe pos : rest) [] binds
70   let orig_file2 = case top_pos of
71                      (file_name:_) 
72                        | ".hsc" `isSuffixOf` unpackFS file_name -> unpackFS file_name
73                      _ -> orig_file
74
75   let mod_name = moduleNameString (moduleName mod)
76
77   let (binds1,_,st)
78                  = unTM (addTickLHsBinds binds) 
79                    (TTE
80                        { fileName    = mkFastString orig_file2
81                       , declPath     = []
82                       , inScope      = emptyVarSet
83                       , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
84                                                     | tyCon <- tyCons ]
85                        })
86                    (TT 
87                       { tickBoxCount = 0
88                       , mixEntries   = []
89                       })
90
91   let entries = reverse $ mixEntries st
92
93   -- write the mix entries for this module
94   hashNo <- if opt_Hpc then do
95      let hpc_dir = hpcDir dflags
96
97      let hpc_mod_dir = if modulePackageId mod == mainPackageId 
98                        then hpc_dir
99                        else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
100
101      let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
102      createDirectoryIfMissing True hpc_mod_dir
103      modTime <- getModificationTime orig_file2
104      let entries' = [ (hpcPos, box) 
105                     | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
106      when (length entries' /= tickBoxCount st) $ do
107        panic "the number of .mix entries are inconsistent"
108      let hashNo = mixHash orig_file2 modTime tabStop entries'
109      mixCreate hpc_mod_dir mod_name 
110                $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
111      return $ hashNo 
112    else do
113      return $ 0
114
115   -- Todo: use proper src span type
116   breakArray <- newBreakArray $ length entries
117
118   let locsTicks = listArray (0,tickBoxCount st-1) 
119                      [ span | (span,_,_,_) <- entries ]
120       varsTicks = listArray (0,tickBoxCount st-1) 
121                      [ vars | (_,_,vars,_) <- entries ]
122       declsTicks= listArray (0,tickBoxCount st-1) 
123                      [ decls | (_,decls,_,_) <- entries ]
124       modBreaks = emptyModBreaks 
125                   { modBreaks_flags = breakArray 
126                   , modBreaks_locs  = locsTicks 
127                   , modBreaks_vars  = varsTicks
128                   , modBreaks_decls = declsTicks
129                   } 
130
131   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
132           printDump (pprLHsBinds binds1)
133
134   return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
135 \end{code}
136
137
138 \begin{code}
139 liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
140 liftL f (L loc a) = do
141   a' <- f a
142   return $ L loc a'
143
144 addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
145 addTickLHsBinds binds = mapBagM addTickLHsBind binds
146
147 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
148 addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
149   binds' <- addTickLHsBinds binds
150   return $ L pos $ bind { abs_binds = binds' }
151 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
152   let name = getOccString id
153   decl_path <- getPathEntry
154
155   (fvs, (MatchGroup matches' ty)) <- 
156         getFreeVars $
157         addPathEntry name $
158         addTickMatchGroup (fun_matches funBind)
159
160   blackListed <- isBlackListed pos
161
162   -- Todo: we don't want redundant ticks on simple pattern bindings
163   -- We don't want to generate code for blacklisted positions
164   if blackListed || (not opt_Hpc && isSimplePatBind funBind)
165      then 
166         return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
167                                  , fun_tick = Nothing 
168                                  }
169      else do
170         tick_no <- allocATickBox (if null decl_path
171                                      then TopLevelBox [name]
172                                      else LocalBox (decl_path ++ [name])) 
173                                 pos fvs
174
175         return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
176                                  , fun_tick = tick_no
177                                  }
178    where
179    -- a binding is a simple pattern binding if it is a funbind with zero patterns
180    isSimplePatBind :: HsBind a -> Bool
181    isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
182
183 -- TODO: Revisit this
184 addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
185   let name = "(...)"
186   rhs' <- addPathEntry name $ addTickGRHSs False rhs
187 {-
188   decl_path <- getPathEntry
189   tick_me <- allocTickBox (if null decl_path
190                            then TopLevelBox [name]
191                            else LocalBox (name : decl_path))
192 -}                         
193   return $ L pos $ pat { pat_rhs = rhs' }
194
195 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
196 addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
197
198 -- Add a tick to the expression no matter what it is.  There is one exception:
199 -- for the debugger, if the expression is a 'let', then we don't want to add
200 -- a tick here because there will definititely be a tick on the body anyway.
201 addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
202 addTickLHsExprAlways (L pos e0)
203   | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
204   | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
205
206 addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
207 addTickLHsExprNeverOrAlways e
208     | opt_Hpc   = addTickLHsExprNever e
209     | otherwise = addTickLHsExprAlways e
210
211 addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
212 addTickLHsExprNeverOrMaybe e
213     | opt_Hpc   = addTickLHsExprNever e
214     | otherwise = addTickLHsExpr e
215
216 -- version of addTick that does not actually add a tick,
217 -- because the scope of this tick is completely subsumed by 
218 -- another.
219 addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
220 addTickLHsExprNever (L pos e0) = do
221     e1 <- addTickHsExpr e0
222     return $ L pos e1
223
224 -- selectively add ticks to interesting expressions
225 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
226 addTickLHsExpr (L pos e0) = do
227     if opt_Hpc || isGoodBreakExpr e0
228        then do
229           allocTickBox (ExpBox False) pos $ addTickHsExpr e0
230        else do
231           e1 <- addTickHsExpr e0
232           return $ L pos e1 
233
234 -- general heuristic: expressions which do not denote values are good break points
235 isGoodBreakExpr :: HsExpr Id -> Bool
236 isGoodBreakExpr (HsApp {})     = True
237 isGoodBreakExpr (OpApp {})     = True
238 isGoodBreakExpr (NegApp {})    = True
239 isGoodBreakExpr (HsCase {})    = True
240 isGoodBreakExpr (HsIf {})      = True
241 isGoodBreakExpr (RecordCon {}) = True
242 isGoodBreakExpr (RecordUpd {}) = True
243 isGoodBreakExpr (ArithSeq {})  = True
244 isGoodBreakExpr (PArrSeq {})   = True
245 isGoodBreakExpr _other         = False 
246
247 addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
248 addTickLHsExprOptAlt oneOfMany (L pos e0)
249   | not opt_Hpc = addTickLHsExpr (L pos e0)
250   | otherwise =
251     allocTickBox (ExpBox oneOfMany) pos $ 
252         addTickHsExpr e0
253
254 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
255 addBinTickLHsExpr boxLabel (L pos e0) =
256     allocBinTickBox boxLabel pos $
257         addTickHsExpr e0
258
259 addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
260 addTickHsExpr e@(HsVar id) = do freeVar id; return e
261 addTickHsExpr e@(HsIPVar _) = return e
262 addTickHsExpr e@(HsOverLit _) = return e
263 addTickHsExpr e@(HsLit _) = return e
264 addTickHsExpr (HsLam matchgroup) =
265         liftM HsLam (addTickMatchGroup matchgroup)
266 addTickHsExpr (HsApp e1 e2) = 
267         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
268 addTickHsExpr (OpApp e1 e2 fix e3) = 
269         liftM4 OpApp 
270                 (addTickLHsExpr e1) 
271                 (addTickLHsExprNever e2)
272                 (return fix)
273                 (addTickLHsExpr e3)
274 addTickHsExpr (NegApp e neg) =
275         liftM2 NegApp
276                 (addTickLHsExpr e) 
277                 (addTickSyntaxExpr hpcSrcSpan neg)
278 addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNeverOrMaybe e)
279 addTickHsExpr (SectionL e1 e2) = 
280         liftM2 SectionL
281                 (addTickLHsExpr e1)
282                 (addTickLHsExpr e2)
283 addTickHsExpr (SectionR e1 e2) = 
284         liftM2 SectionR
285                 (addTickLHsExpr e1)
286                 (addTickLHsExpr e2)
287 addTickHsExpr (ExplicitTuple es boxity) =
288         liftM2 ExplicitTuple
289                 (mapM addTickTupArg es)
290                 (return boxity)
291 addTickHsExpr (HsCase e mgs) = 
292         liftM2 HsCase
293                 (addTickLHsExpr e) 
294                 (addTickMatchGroup mgs)
295 addTickHsExpr (HsIf cnd e1 e2 e3) = 
296         liftM3 (HsIf cnd)
297                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
298                 (addTickLHsExprOptAlt True e2)
299                 (addTickLHsExprOptAlt True e3)
300 addTickHsExpr (HsLet binds e) =
301         bindLocals (collectLocalBinders binds) $
302         liftM2 HsLet
303                 (addTickHsLocalBinds binds) -- to think about: !patterns.
304                 (addTickLHsExprNeverOrAlways e)
305 addTickHsExpr (HsDo cxt stmts srcloc) 
306   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
307        ; return (HsDo cxt stmts' srcloc) }
308   where
309         forQual = case cxt of
310                     ListComp -> Just $ BinBox QualBinBox
311                     _        -> Nothing
312 addTickHsExpr (ExplicitList ty es) = 
313         liftM2 ExplicitList
314                 (return ty)
315                 (mapM (addTickLHsExpr) es)
316 addTickHsExpr (ExplicitPArr ty es) =
317         liftM2 ExplicitPArr
318                 (return ty)
319                 (mapM (addTickLHsExpr) es)
320 addTickHsExpr (RecordCon id ty rec_binds) = 
321         liftM3 RecordCon
322                 (return id)
323                 (return ty)
324                 (addTickHsRecordBinds rec_binds)
325 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
326         liftM5 RecordUpd
327                 (addTickLHsExpr e)
328                 (addTickHsRecordBinds rec_binds)
329                 (return cons) (return tys1) (return tys2)
330
331 addTickHsExpr (ExprWithTySigOut e ty) =
332         liftM2 ExprWithTySigOut
333                 (addTickLHsExprNever e) -- No need to tick the inner expression
334                                     -- for expressions with signatures
335                 (return ty)
336 addTickHsExpr (ArithSeq  ty arith_seq) =
337         liftM2 ArithSeq 
338                 (return ty)
339                 (addTickArithSeqInfo arith_seq)
340 addTickHsExpr (HsTickPragma _ (L pos e0)) = do
341     e2 <- allocTickBox (ExpBox False) pos $
342                 addTickHsExpr e0
343     return $ unLoc e2
344 addTickHsExpr (PArrSeq   ty arith_seq) =
345         liftM2 PArrSeq  
346                 (return ty)
347                 (addTickArithSeqInfo arith_seq)
348 addTickHsExpr (HsSCC nm e) =
349         liftM2 HsSCC 
350                 (return nm)
351                 (addTickLHsExpr e)
352 addTickHsExpr (HsCoreAnn nm e) = 
353         liftM2 HsCoreAnn 
354                 (return nm)
355                 (addTickLHsExpr e)
356 addTickHsExpr e@(HsBracket     {}) = return e
357 addTickHsExpr e@(HsBracketOut  {}) = return e
358 addTickHsExpr e@(HsSpliceE  {}) = return e
359 addTickHsExpr (HsProc pat cmdtop) =
360         liftM2 HsProc
361                 (addTickLPat pat)
362                 (liftL (addTickHsCmdTop) cmdtop)
363 addTickHsExpr (HsWrap w e) = 
364         liftM2 HsWrap
365                 (return w)
366                 (addTickHsExpr e)       -- explicitly no tick on inside
367
368 addTickHsExpr e@(HsType _) = return e
369
370 -- Others dhould never happen in expression content.
371 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
372
373 addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
374 addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
375 addTickTupArg (Missing ty) = return (Missing ty)
376
377 addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
378 addTickMatchGroup (MatchGroup matches ty) = do
379   let isOneOfMany = matchesOneOfMany matches
380   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
381   return $ MatchGroup matches' ty
382
383 addTickMatch :: Bool -> Match Id -> TM (Match Id)
384 addTickMatch isOneOfMany (Match pats opSig gRHSs) =
385   bindLocals (collectPatsBinders pats) $ do
386     gRHSs' <- addTickGRHSs isOneOfMany gRHSs
387     return $ Match pats opSig gRHSs'
388
389 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
390 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
391   bindLocals binders $ do
392     local_binds' <- addTickHsLocalBinds local_binds
393     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
394     return $ GRHSs guarded' local_binds'
395   where
396     binders = collectLocalBinders local_binds
397
398 addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
399 addTickGRHS isOneOfMany (GRHS stmts expr) = do
400   (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
401                         (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
402                                     else addTickLHsExprAlways expr)
403   return $ GRHS stmts' expr'
404
405 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
406 addTickLStmts isGuard stmts = do
407   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
408   return stmts
409
410 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
411                -> TM ([LStmt Id], a)
412 addTickLStmts' isGuard lstmts res
413   = bindLocals (collectLStmtsBinders lstmts) $ 
414     do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
415        ; a <- res
416        ; return (lstmts', a) }
417
418 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
419 addTickStmt _isGuard (LastStmt e ret) = do
420         liftM2 LastStmt
421                 (addTickLHsExpr e)
422                 (addTickSyntaxExpr hpcSrcSpan ret)
423 addTickStmt _isGuard (BindStmt pat e bind fail) = do
424         liftM4 BindStmt
425                 (addTickLPat pat)
426                 (addTickLHsExprAlways e)
427                 (addTickSyntaxExpr hpcSrcSpan bind)
428                 (addTickSyntaxExpr hpcSrcSpan fail)
429 addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
430         liftM4 ExprStmt
431                 (addTick isGuard e)
432                 (addTickSyntaxExpr hpcSrcSpan bind')
433                 (addTickSyntaxExpr hpcSrcSpan guard')
434                 (return ty)
435 addTickStmt _isGuard (LetStmt binds) = do
436         liftM LetStmt
437                 (addTickHsLocalBinds binds)
438 addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
439     liftM4 ParStmt 
440         (mapM (addTickStmtAndBinders isGuard) pairs)
441         (addTickSyntaxExpr hpcSrcSpan mzipExpr)
442         (addTickSyntaxExpr hpcSrcSpan bindExpr)
443         (addTickSyntaxExpr hpcSrcSpan returnExpr)
444
445 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
446                                     , trS_by = by, trS_using = using
447                                     , trS_ret = returnExpr, trS_bind = bindExpr
448                                     , trS_fmap = liftMExpr }) = do
449     t_s <- addTickLStmts isGuard stmts
450     t_y <- fmapMaybeM  addTickLHsExprAlways by
451     t_u <- addTickLHsExprAlways using
452     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
453     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
454     t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
455     return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
456                   , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
457
458 addTickStmt isGuard stmt@(RecStmt {})
459   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
460        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
461        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
462        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
463        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
464                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
465
466 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
467 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
468                   | otherwise          = addTickLHsExprAlways e
469
470 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
471                       -> TM ([LStmt Id], a)
472 addTickStmtAndBinders isGuard (stmts, ids) = 
473     liftM2 (,) 
474         (addTickLStmts isGuard stmts)
475         (return ids)
476
477 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
478 addTickHsLocalBinds (HsValBinds binds) = 
479         liftM HsValBinds 
480                 (addTickHsValBinds binds)
481 addTickHsLocalBinds (HsIPBinds binds)  = 
482         liftM HsIPBinds 
483                 (addTickHsIPBinds binds)
484 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
485
486 addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
487 addTickHsValBinds (ValBindsOut binds sigs) =
488         liftM2 ValBindsOut
489                 (mapM (\ (rec,binds') -> 
490                                 liftM2 (,)
491                                         (return rec)
492                                         (addTickLHsBinds binds'))
493                         binds)
494                 (return sigs)
495 addTickHsValBinds _ = panic "addTickHsValBinds"
496
497 addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
498 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
499         liftM2 IPBinds
500                 (mapM (liftL (addTickIPBind)) ipbinds)
501                 (return dictbinds)
502
503 addTickIPBind :: IPBind Id -> TM (IPBind Id)
504 addTickIPBind (IPBind nm e) =
505         liftM2 IPBind
506                 (return nm)
507                 (addTickLHsExpr e)
508
509 -- There is no location here, so we might need to use a context location??
510 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
511 addTickSyntaxExpr pos x = do
512         L _ x' <- addTickLHsExpr (L pos x)
513         return $ x'
514 -- we do not walk into patterns.
515 addTickLPat :: LPat Id -> TM (LPat Id)
516 addTickLPat pat = return pat
517
518 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
519 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
520         liftM4 HsCmdTop
521                 (addTickLHsCmd cmd)
522                 (return tys)
523                 (return ty)
524                 (return syntaxtable)
525
526 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
527 addTickLHsCmd (L pos c0) = do
528         c1 <- addTickHsCmd c0
529         return $ L pos c1 
530
531 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
532 addTickHsCmd (HsLam matchgroup) =
533         liftM HsLam (addTickCmdMatchGroup matchgroup)
534 addTickHsCmd (HsApp c e) = 
535         liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
536 addTickHsCmd (OpApp e1 c2 fix c3) = 
537         liftM4 OpApp 
538                 (addTickLHsExpr e1) 
539                 (addTickLHsCmd c2)
540                 (return fix)
541                 (addTickLHsCmd c3)
542 addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
543 addTickHsCmd (HsCase e mgs) = 
544         liftM2 HsCase
545                 (addTickLHsExpr e) 
546                 (addTickCmdMatchGroup mgs)
547 addTickHsCmd (HsIf cnd e1 c2 c3) = 
548         liftM3 (HsIf cnd)
549                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
550                 (addTickLHsCmd c2)
551                 (addTickLHsCmd c3)
552 addTickHsCmd (HsLet binds c) =
553         bindLocals (collectLocalBinders binds) $
554         liftM2 HsLet
555                 (addTickHsLocalBinds binds) -- to think about: !patterns.
556                 (addTickLHsCmd c)
557 addTickHsCmd (HsDo cxt stmts srcloc)
558   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
559        ; return (HsDo cxt stmts' srcloc) }
560
561 addTickHsCmd (HsArrApp   e1 e2 ty1 arr_ty lr) = 
562         liftM5 HsArrApp
563                (addTickLHsExpr e1)
564                (addTickLHsExpr e2)
565                (return ty1)
566                (return arr_ty)
567                (return lr)
568 addTickHsCmd (HsArrForm e fix cmdtop) = 
569         liftM3 HsArrForm
570                (addTickLHsExpr e)
571                (return fix)
572                (mapM (liftL (addTickHsCmdTop)) cmdtop)
573
574 -- Others should never happen in a command context.
575 addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
576
577 addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
578 addTickCmdMatchGroup (MatchGroup matches ty) = do
579   matches' <- mapM (liftL addTickCmdMatch) matches
580   return $ MatchGroup matches' ty
581
582 addTickCmdMatch :: Match Id -> TM (Match Id)
583 addTickCmdMatch (Match pats opSig gRHSs) =
584   bindLocals (collectPatsBinders pats) $ do
585     gRHSs' <- addTickCmdGRHSs gRHSs
586     return $ Match pats opSig gRHSs'
587
588 addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
589 addTickCmdGRHSs (GRHSs guarded local_binds) = do
590   bindLocals binders $ do
591     local_binds' <- addTickHsLocalBinds local_binds
592     guarded' <- mapM (liftL addTickCmdGRHS) guarded
593     return $ GRHSs guarded' local_binds'
594   where
595     binders = collectLocalBinders local_binds
596
597 addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
598 -- The *guards* are *not* Cmds, although the body is
599 -- C.f. addTickGRHS for the BinBox stuff
600 addTickCmdGRHS (GRHS stmts cmd)
601   = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) 
602                                    stmts (addTickLHsCmd cmd)
603        ; return $ GRHS stmts' expr' }
604
605 addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
606 addTickLCmdStmts stmts = do
607   (stmts, _) <- addTickLCmdStmts' stmts (return ())
608   return stmts
609
610 addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
611 addTickLCmdStmts' lstmts res
612   = bindLocals binders $ do
613         lstmts' <- mapM (liftL addTickCmdStmt) lstmts
614         a <- res
615         return (lstmts', a)
616   where
617         binders = collectLStmtsBinders lstmts
618
619 addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
620 addTickCmdStmt (BindStmt pat c bind fail) = do
621         liftM4 BindStmt
622                 (addTickLPat pat)
623                 (addTickLHsCmd c)
624                 (return bind)
625                 (return fail)
626 addTickCmdStmt (LastStmt c ret) = do
627         liftM2 LastStmt
628                 (addTickLHsCmd c)
629                 (addTickSyntaxExpr hpcSrcSpan ret)
630 addTickCmdStmt (ExprStmt c bind' guard' ty) = do
631         liftM4 ExprStmt
632                 (addTickLHsCmd c)
633                 (addTickSyntaxExpr hpcSrcSpan bind')
634                 (addTickSyntaxExpr hpcSrcSpan guard')
635                 (return ty)
636 addTickCmdStmt (LetStmt binds) = do
637         liftM LetStmt
638                 (addTickHsLocalBinds binds)
639 addTickCmdStmt stmt@(RecStmt {})
640   = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
641        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
642        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
643        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
644        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
645                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
646
647 -- Others should never happen in a command context.
648 addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
649
650 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
651 addTickHsRecordBinds (HsRecFields fields dd) 
652   = do  { fields' <- mapM process fields
653         ; return (HsRecFields fields' dd) }
654   where
655     process (HsRecField ids expr doc)
656         = do { expr' <- addTickLHsExpr expr
657              ; return (HsRecField ids expr' doc) }
658
659 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
660 addTickArithSeqInfo (From e1) =
661         liftM From
662                 (addTickLHsExpr e1)
663 addTickArithSeqInfo (FromThen e1 e2) =
664         liftM2 FromThen
665                 (addTickLHsExpr e1)
666                 (addTickLHsExpr e2)
667 addTickArithSeqInfo (FromTo e1 e2) =
668         liftM2 FromTo
669                 (addTickLHsExpr e1)
670                 (addTickLHsExpr e2)
671 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
672         liftM3 FromThenTo
673                 (addTickLHsExpr e1)
674                 (addTickLHsExpr e2)
675                 (addTickLHsExpr e3)
676 \end{code}
677
678 \begin{code}
679 data TickTransState = TT { tickBoxCount:: Int
680                          , mixEntries  :: [MixEntry_]
681                          }                        
682
683 data TickTransEnv = TTE { fileName      :: FastString
684                         , declPath     :: [String]
685                         , inScope      :: VarSet
686                         , blackList   :: Map SrcSpan ()
687                         }
688
689 --      deriving Show
690
691 type FreeVars = OccEnv Id
692 noFVs :: FreeVars
693 noFVs = emptyOccEnv
694
695 -- Note [freevars]
696 --   For breakpoints we want to collect the free variables of an
697 --   expression for pinning on the HsTick.  We don't want to collect
698 --   *all* free variables though: in particular there's no point pinning
699 --   on free variables that are will otherwise be in scope at the GHCi
700 --   prompt, which means all top-level bindings.  Unfortunately detecting
701 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
702 --   bindings doesn't do it), so we keep track of a set of "in-scope"
703 --   variables in addition to the free variables, and the former is used
704 --   to filter additions to the latter.  This gives us complete control
705 --   over what free variables we track.
706
707 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
708         -- a combination of a state monad (TickTransState) and a writer
709         -- monad (FreeVars).
710
711 instance Monad TM where
712   return a = TM $ \ _env st -> (a,noFVs,st)
713   (TM m) >>= k = TM $ \ env st -> 
714                                 case m env st of
715                                   (r1,fv1,st1) -> 
716                                      case unTM (k r1) env st1 of
717                                        (r2,fv2,st2) -> 
718                                           (r2, fv1 `plusOccEnv` fv2, st2)
719
720 -- getState :: TM TickTransState
721 -- getState = TM $ \ env st -> (st, noFVs, st)
722
723 -- setState :: (TickTransState -> TickTransState) -> TM ()
724 -- setState f = TM $ \ env st -> ((), noFVs, f st)
725
726 getEnv :: TM TickTransEnv
727 getEnv = TM $ \ env st -> (env, noFVs, st)
728
729 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
730 withEnv f (TM m) = TM $ \ env st -> 
731                                  case m (f env) st of
732                                    (a, fvs, st') -> (a, fvs, st')
733
734 getFreeVars :: TM a -> TM (FreeVars, a)
735 getFreeVars (TM m) 
736   = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
737
738 freeVar :: Id -> TM ()
739 freeVar id = TM $ \ env st -> 
740                 if id `elemVarSet` inScope env
741                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
742                    else ((), noFVs, st)
743
744 addPathEntry :: String -> TM a -> TM a
745 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
746
747 getPathEntry :: TM [String]
748 getPathEntry = declPath `liftM` getEnv
749
750 getFileName :: TM FastString
751 getFileName = fileName `liftM` getEnv
752
753 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
754 sameFileName pos out_of_scope in_scope = do
755   file_name <- getFileName
756   case srcSpanFileName_maybe pos of 
757     Just file_name2 
758       | file_name == file_name2 -> in_scope
759     _ -> out_of_scope
760
761 bindLocals :: [Id] -> TM a -> TM a
762 bindLocals new_ids (TM m)
763   = TM $ \ env st -> 
764                  case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
765                    (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
766   where occs = [ nameOccName (idName id) | id <- new_ids ] 
767
768 isBlackListed :: SrcSpan -> TM Bool
769 isBlackListed pos = TM $ \ env st -> 
770               case Map.lookup pos (blackList env) of
771                 Nothing -> (False,noFVs,st)
772                 Just () -> (True,noFVs,st)
773
774 -- the tick application inherits the source position of its
775 -- expression argument to support nested box allocations 
776 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
777 allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 
778   sameFileName pos 
779     (do e <- m; return (L pos e)) $ do
780   (fvs, e) <- getFreeVars m
781   TM $ \ env st ->
782     let c = tickBoxCount st
783         ids = occEnvElts fvs
784         mes = mixEntries st
785         me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
786     in
787     ( L pos (HsTick c ids (L pos e))
788     , fvs
789     , st {tickBoxCount=c+1,mixEntries=me:mes}
790     )
791 allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
792
793 -- the tick application inherits the source position of its
794 -- expression argument to support nested box allocations 
795 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
796 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
797   sameFileName pos 
798     (return Nothing) $ TM $ \ env st ->
799   let mydecl_path
800         | null (declPath env), TopLevelBox x <- boxLabel = x
801         | otherwise = declPath env
802       me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
803       c = tickBoxCount st
804       mes = mixEntries st
805       ids = occEnvElts fvs
806   in ( Just (c, ids)
807      , noFVs
808      , st {tickBoxCount=c+1, mixEntries=me:mes}
809      )
810 allocATickBox _boxLabel _pos _fvs = return Nothing
811
812 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
813                 -> TM (LHsExpr Id)
814 allocBinTickBox boxLabel pos m
815  | not opt_Hpc = allocTickBox (ExpBox False) pos m
816  | isGoodSrcSpan' pos =
817  do
818  e <- m
819  TM $ \ env st ->
820   let meT = (pos,declPath env, [],boxLabel True)
821       meF = (pos,declPath env, [],boxLabel False)
822       meE = (pos,declPath env, [],ExpBox False)
823       c = tickBoxCount st
824       mes = mixEntries st
825   in 
826              ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
827            -- notice that F and T are reversed,
828            -- because we are building the list in
829            -- reverse...
830              , noFVs
831              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
832              )
833 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
834
835 isGoodSrcSpan' :: SrcSpan -> Bool
836 isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
837 isGoodSrcSpan' (UnhelpfulSpan _) = False
838
839 mkHpcPos :: SrcSpan -> HpcPos
840 mkHpcPos pos@(RealSrcSpan s)
841    | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
842                                     srcSpanStartCol s,
843                                     srcSpanEndLine s,
844                                     srcSpanEndCol s - 1)
845                               -- the end column of a SrcSpan is one
846                               -- greater than the last column of the
847                               -- span (see SrcLoc), whereas HPC
848                               -- expects to the column range to be
849                               -- inclusive, hence we subtract one above.
850 mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
851
852 hpcSrcSpan :: SrcSpan
853 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
854 \end{code}
855
856
857 \begin{code}
858 matchesOneOfMany :: [LMatch Id] -> Bool
859 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
860   where
861         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
862 \end{code}
863
864
865 \begin{code}
866 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
867
868 -- For the hash value, we hash everything: the file name, 
869 --  the timestamp of the original source file, the tab stop,
870 --  and the mix entries. We cheat, and hash the show'd string.
871 -- This hash only has to be hashed at Mix creation time,
872 -- and is for sanity checking only.
873
874 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
875 mixHash file tm tabstop entries = fromIntegral $ hashString
876         (show $ Mix file tm 0 tabstop entries)
877 \end{code}
878
879 %************************************************************************
880 %*                                                                      *
881 %*              initialisation
882 %*                                                                      *
883 %************************************************************************
884
885 Each module compiled with -fhpc declares an initialisation function of
886 the form `hpc_init_<module>()`, which is emitted into the _stub.c file
887 and annotated with __attribute__((constructor)) so that it gets
888 executed at startup time.
889
890 The function's purpose is to call hs_hpc_module to register this
891 module with the RTS, and it looks something like this:
892
893 static void hpc_init_Main(void) __attribute__((constructor));
894 static void hpc_init_Main(void)
895 {extern StgWord64 _hpc_tickboxes_Main_hpc[];
896  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
897
898 \begin{code}
899 hpcInitCode :: Platform -> Module -> HpcInfo -> SDoc
900 hpcInitCode _ _ (NoHpcInfo {}) = empty
901 hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
902  = vcat
903     [ text "static void hpc_init_" <> ppr this_mod
904          <> text "(void) __attribute__((constructor));"
905     , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
906     , braces (vcat [
907         ptext (sLit "extern StgWord64 ") <> tickboxes <>
908                ptext (sLit "[]") <> semi,
909         ptext (sLit "hs_hpc_module") <>
910           parens (hcat (punctuate comma [
911               doubleQuotes full_name_str,
912               int tickCount, -- really StgWord32
913               int hashNo,    -- really StgWord32
914               tickboxes
915             ])) <> semi
916        ])
917     ]
918   where
919     tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)
920
921     module_name  = hcat (map (text.charToC) $
922                          bytesFS (moduleNameFS (Module.moduleName this_mod)))
923     package_name = hcat (map (text.charToC) $
924                          bytesFS (packageIdFS  (modulePackageId this_mod)))
925     full_name_str
926        | modulePackageId this_mod == mainPackageId
927        = module_name
928        | otherwise
929        = package_name <> char '/' <> module_name
930 \end{code}