Coverage.lhs 31.7 KB
Newer Older
andy@galois.com's avatar
andy@galois.com committed
1 2
%
% (c) Galois, 2006
3
% (c) University of Glasgow, 2007
andy@galois.com's avatar
andy@galois.com committed
4 5 6 7
%
\section[Coverage]{@coverage@: the main function}

\begin{code}
8
module Coverage (addCoverageTicksToBinds, hpcInitCode) where
andy@galois.com's avatar
andy@galois.com committed
9 10 11 12

import HsSyn
import Module
import Outputable
13
import DynFlags
Ian Lynagh's avatar
Ian Lynagh committed
14
import Control.Monad
andy@galois.com's avatar
andy@galois.com committed
15
import SrcLoc
16
import ErrUtils
andy@galois.com's avatar
andy@galois.com committed
17 18
import Name
import Bag
19
import Id
20
import VarSet
21 22
import Data.List
import FastString
23
import HscTypes	
24
import StaticFlags
25
import TyCon
26
import MonadUtils
27
import Maybes
28 29
import CLabel
import Util
andy@galois.com's avatar
andy@galois.com committed
30

31
import Data.Array
andy@galois.com's avatar
andy@galois.com committed
32
import System.Directory ( createDirectoryIfMissing )
33

34 35 36
import Trace.Hpc.Mix
import Trace.Hpc.Util

37
import BreakArray 
38
import Data.HashTable   ( hashString )
39 40
import Data.Map (Map)
import qualified Data.Map as Map
andy@galois.com's avatar
andy@galois.com committed
41 42
\end{code}

43

andy@galois.com's avatar
andy@galois.com committed
44 45 46 47 48 49 50
%************************************************************************
%*									*
%* 		The main function: addCoverageTicksToBinds
%*									*
%************************************************************************

\begin{code}
51 52 53 54
addCoverageTicksToBinds
        :: DynFlags
        -> Module
        -> ModLocation          -- of the current module
55
        -> [TyCon]		-- type constructor in this module
56
        -> LHsBinds Id
57
        -> IO (LHsBinds Id, HpcInfo, ModBreaks)
58

59 60 61 62
addCoverageTicksToBinds dflags mod mod_loc tyCons binds = 
 case ml_hs_file mod_loc of
 Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks)
 Just orig_file -> do
63

64
  if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
65

66 67 68 69 70 71 72 73
  -- Now, we try look for a file generated from a .hsc file to a .hs file, by peeking ahead.

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

andy@galois.com's avatar
andy@galois.com committed
74 75
  let mod_name = moduleNameString (moduleName mod)

76
  let (binds1,_,st)
andy@galois.com's avatar
andy@galois.com committed
77
		 = unTM (addTickLHsBinds binds) 
78
		   (TTE
79
		       { fileName    = mkFastString orig_file2
andy@galois.com's avatar
andy@galois.com committed
80
		      , declPath     = []
81
                      , inScope      = emptyVarSet
82 83
		      , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
		                                    | tyCon <- tyCons ]
84
		       })
85 86
		   (TT 
		      { tickBoxCount = 0
andy@galois.com's avatar
andy@galois.com committed
87
		      , mixEntries   = []
88
		      })
andy@galois.com's avatar
andy@galois.com committed
89

90
  let entries = reverse $ mixEntries st
andy@galois.com's avatar
andy@galois.com committed
91 92

  -- write the mix entries for this module
93
  hashNo <- if opt_Hpc then do
94
     let hpc_dir = hpcDir dflags
95 96 97 98 99

     let hpc_mod_dir = if modulePackageId mod == mainPackageId 
		       then hpc_dir
		       else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)

100
     let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
101
     createDirectoryIfMissing True hpc_mod_dir
102
     modTime <- getModificationTime orig_file2
103
     let entries' = [ (hpcPos, box) 
104
                    | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
105 106
     when (length entries' /= tickBoxCount st) $ do
       panic "the number of .mix entries are inconsistent"
107
     let hashNo = mixHash orig_file2 modTime tabStop entries'
108
     mixCreate hpc_mod_dir mod_name 
109
     	       $ Mix orig_file2 modTime (toHash hashNo) tabStop entries'
110 111 112
     return $ hashNo 
   else do
     return $ 0
113 114 115

  -- Todo: use proper src span type
  breakArray <- newBreakArray $ length entries
116

117
  let locsTicks = listArray (0,tickBoxCount st-1) 
118
                     [ span | (span,_,_,_) <- entries ]
119
      varsTicks = listArray (0,tickBoxCount st-1) 
120 121 122
                     [ vars | (_,_,vars,_) <- entries ]
      declsTicks= listArray (0,tickBoxCount st-1) 
                     [ decls | (_,decls,_,_) <- entries ]
123
      modBreaks = emptyModBreaks 
124 125
                  { modBreaks_flags = breakArray 
                  , modBreaks_locs  = locsTicks 
126
                  , modBreaks_vars  = varsTicks
127
                  , modBreaks_decls = declsTicks
128
                  } 
andy@galois.com's avatar
andy@galois.com committed
129 130 131

  doIfSet_dyn dflags  Opt_D_dump_hpc $ do
	  printDump (pprLHsBinds binds1)
132

133
  return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
andy@galois.com's avatar
andy@galois.com committed
134 135 136 137 138 139 140 141 142 143 144 145 146
\end{code}


\begin{code}
liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)
liftL f (L loc a) = do
  a' <- f a
  return $ L loc a'

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

addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
147 148 149
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
  binds' <- addTickLHsBinds binds
  return $ L pos $ bind { abs_binds = binds' }
150
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
andy@galois.com's avatar
andy@galois.com committed
151 152 153
  let name = getOccString id
  decl_path <- getPathEntry

154
  (fvs, (MatchGroup matches' ty)) <- 
155
        getFreeVars $
156
        addPathEntry name $
157
        addTickMatchGroup (fun_matches funBind)
158

159 160
  blackListed <- isBlackListed pos

161
  -- Todo: we don't want redundant ticks on simple pattern bindings
162 163
  -- We don't want to generate code for blacklisted positions
  if blackListed || (not opt_Hpc && isSimplePatBind funBind)
164 165 166 167 168 169 170
     then 
        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
                                 , fun_tick = Nothing 
                                 }
     else do
        tick_no <- allocATickBox (if null decl_path
                                     then TopLevelBox [name]
171
                                     else LocalBox (decl_path ++ [name])) 
172
                                pos fvs
173 174 175 176 177 178 179 180

        return $ L pos $ funBind { fun_matches = MatchGroup matches' ty 
                                 , fun_tick = tick_no
                                 }
   where
   -- a binding is a simple pattern binding if it is a funbind with zero patterns
   isSimplePatBind :: HsBind a -> Bool
   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
andy@galois.com's avatar
andy@galois.com committed
181 182 183 184

-- TODO: Revisit this
addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do
  let name = "(...)"
185
  rhs' <- addPathEntry name $ addTickGRHSs False rhs
andy@galois.com's avatar
andy@galois.com committed
186 187 188 189 190 191 192 193
{-
  decl_path <- getPathEntry
  tick_me <- allocTickBox (if null decl_path
			   then TopLevelBox [name]
			   else LocalBox (name : decl_path))
-}			   
  return $ L pos $ pat { pat_rhs = rhs' }

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

197 198 199
-- Add a tick to the expression no matter what it is.  There is one exception:
-- for the debugger, if the expression is a 'let', then we don't want to add
-- a tick here because there will definititely be a tick on the body anyway.
200
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
201 202 203
addTickLHsExprAlways (L pos e0)
  | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
  | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
204

205 206 207
addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrAlways e
    | opt_Hpc   = addTickLHsExprNever e
208 209
    | otherwise = addTickLHsExprAlways e

210 211 212 213 214
addTickLHsExprNeverOrMaybe :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrMaybe e
    | opt_Hpc   = addTickLHsExprNever e
    | otherwise = addTickLHsExpr e

215 216 217 218 219 220 221 222
-- version of addTick that does not actually add a tick,
-- because the scope of this tick is completely subsumed by 
-- another.
addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNever (L pos e0) = do
    e1 <- addTickHsExpr e0
    return $ L pos e1

223 224 225 226 227
-- selectively add ticks to interesting expressions
addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExpr (L pos e0) = do
    if opt_Hpc || isGoodBreakExpr e0
       then do
228
          allocTickBox (ExpBox False) pos $ addTickHsExpr e0
229 230
       else do
          e1 <- addTickHsExpr e0
231 232 233 234 235 236 237 238 239 240 241 242 243
          return $ L pos e1 

-- general heuristic: expressions which do not denote values are good break points
isGoodBreakExpr :: HsExpr Id -> Bool
isGoodBreakExpr (HsApp {})     = True
isGoodBreakExpr (OpApp {})     = True
isGoodBreakExpr (NegApp {})    = True
isGoodBreakExpr (HsCase {})    = True
isGoodBreakExpr (HsIf {})      = True
isGoodBreakExpr (RecordCon {}) = True
isGoodBreakExpr (RecordUpd {}) = True
isGoodBreakExpr (ArithSeq {})  = True
isGoodBreakExpr (PArrSeq {})   = True
244
isGoodBreakExpr _other         = False 
245

andy@galois.com's avatar
andy@galois.com committed
246
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
247 248
addTickLHsExprOptAlt oneOfMany (L pos e0)
  | not opt_Hpc = addTickLHsExpr (L pos e0)
249
  | otherwise =
250
    allocTickBox (ExpBox oneOfMany) pos $ 
251
        addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
252 253

addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
254 255 256
addBinTickLHsExpr boxLabel (L pos e0) =
    allocBinTickBox boxLabel pos $
        addTickHsExpr e0
andy@galois.com's avatar
andy@galois.com committed
257 258

addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
259
addTickHsExpr e@(HsVar id) = do freeVar id; return e
andy@galois.com's avatar
andy@galois.com committed
260 261 262
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
addTickHsExpr e@(HsLit _) = return e
263
addTickHsExpr (HsLam matchgroup) =
andy@galois.com's avatar
andy@galois.com committed
264 265
        liftM HsLam (addTickMatchGroup matchgroup)
addTickHsExpr (HsApp e1 e2) = 
266
	liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
andy@galois.com's avatar
andy@galois.com committed
267 268 269
addTickHsExpr (OpApp e1 e2 fix e3) = 
	liftM4 OpApp 
		(addTickLHsExpr e1) 
270
		(addTickLHsExprNever e2)
andy@galois.com's avatar
andy@galois.com committed
271 272
		(return fix)
		(addTickLHsExpr e3)
273
addTickHsExpr (NegApp e neg) =
andy@galois.com's avatar
andy@galois.com committed
274 275 276
	liftM2 NegApp
		(addTickLHsExpr e) 
		(addTickSyntaxExpr hpcSrcSpan neg)
277
addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNeverOrMaybe e)
andy@galois.com's avatar
andy@galois.com committed
278 279 280 281 282 283 284 285
addTickHsExpr (SectionL e1 e2) = 
	liftM2 SectionL
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickHsExpr (SectionR e1 e2) = 
	liftM2 SectionR
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
286 287 288 289
addTickHsExpr (ExplicitTuple es boxity) =
        liftM2 ExplicitTuple
                (mapM addTickTupArg es)
                (return boxity)
andy@galois.com's avatar
andy@galois.com committed
290 291 292 293
addTickHsExpr (HsCase e mgs) = 
	liftM2 HsCase
		(addTickLHsExpr e) 
		(addTickMatchGroup mgs)
294 295
addTickHsExpr (HsIf cnd e1 e2 e3) = 
	liftM3 (HsIf cnd)
296
		(addBinTickLHsExpr (BinBox CondBinBox) e1)
andy@galois.com's avatar
andy@galois.com committed
297 298 299
		(addTickLHsExprOptAlt True e2)
		(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
300
	bindLocals (collectLocalBinders binds) $
andy@galois.com's avatar
andy@galois.com committed
301
	liftM2 HsLet
302 303
		(addTickHsLocalBinds binds) -- to think about: !patterns.
                (addTickLHsExprNeverOrAlways e)
304 305 306
addTickHsExpr (HsDo cxt stmts srcloc) 
  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
andy@galois.com's avatar
andy@galois.com committed
307 308
  where
	forQual = case cxt of
309
		    ListComp -> Just $ BinBox QualBinBox
andy@galois.com's avatar
andy@galois.com committed
310 311
		    _        -> Nothing
addTickHsExpr (ExplicitList ty es) = 
312
	liftM2 ExplicitList
andy@galois.com's avatar
andy@galois.com committed
313
		(return ty)
314
		(mapM (addTickLHsExpr) es)
315 316 317 318
addTickHsExpr (ExplicitPArr ty es) =
	liftM2 ExplicitPArr
		(return ty)
		(mapM (addTickLHsExpr) es)
319
addTickHsExpr (RecordCon id ty rec_binds) = 
andy@galois.com's avatar
andy@galois.com committed
320 321 322 323
	liftM3 RecordCon
		(return id)
		(return ty)
		(addTickHsRecordBinds rec_binds)
324 325
addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
	liftM5 RecordUpd
andy@galois.com's avatar
andy@galois.com committed
326 327
		(addTickLHsExpr e)
		(addTickHsRecordBinds rec_binds)
328 329
		(return cons) (return tys1) (return tys2)

andy@galois.com's avatar
andy@galois.com committed
330 331
addTickHsExpr (ExprWithTySigOut e ty) =
	liftM2 ExprWithTySigOut
332
		(addTickLHsExprNever e) -- No need to tick the inner expression
andy@galois.com's avatar
andy@galois.com committed
333 334 335 336 337 338
				    -- for expressions with signatures
		(return ty)
addTickHsExpr (ArithSeq	 ty arith_seq) =
	liftM2 ArithSeq	
		(return ty)
		(addTickArithSeqInfo arith_seq)
339
addTickHsExpr (HsTickPragma _ (L pos e0)) = do
340
    e2 <- allocTickBox (ExpBox False) pos $
341
                addTickHsExpr e0
342
    return $ unLoc e2
343 344 345 346 347 348 349 350 351 352 353 354
addTickHsExpr (PArrSeq	 ty arith_seq) =
	liftM2 PArrSeq	
		(return ty)
		(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC nm e) =
        liftM2 HsSCC 
                (return nm)
                (addTickLHsExpr e)
addTickHsExpr (HsCoreAnn nm e) = 
        liftM2 HsCoreAnn 
                (return nm)
                (addTickLHsExpr e)
andy@galois.com's avatar
andy@galois.com committed
355 356 357 358 359 360
addTickHsExpr e@(HsBracket     {}) = return e
addTickHsExpr e@(HsBracketOut  {}) = return e
addTickHsExpr e@(HsSpliceE  {}) = return e
addTickHsExpr (HsProc pat cmdtop) =
	liftM2 HsProc
		(addTickLPat pat)
361
		(liftL (addTickHsCmdTop) cmdtop)
andy@galois.com's avatar
andy@galois.com committed
362 363 364 365
addTickHsExpr (HsWrap w e) = 
	liftM2 HsWrap
		(return w)
		(addTickHsExpr e)	-- explicitly no tick on inside
366

367 368 369 370 371 372 373 374 375 376 377 378 379 380
addTickHsExpr (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
        liftM5 HsArrApp
	       (addTickLHsExpr e1)
	       (addTickLHsExpr e2)
	       (return ty1)
	       (return arr_ty)
	       (return lr)

addTickHsExpr (HsArrForm e fix cmdtop) = 
        liftM3 HsArrForm
	       (addTickLHsExpr e)
	       (return fix)
	       (mapM (liftL (addTickHsCmdTop)) cmdtop)

381
addTickHsExpr e@(HsType _) = return e
382

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

386 387 388 389
addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)

390
addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
andy@galois.com's avatar
andy@galois.com committed
391
addTickMatchGroup (MatchGroup matches ty) = do
392
  let isOneOfMany = matchesOneOfMany matches
andy@galois.com's avatar
andy@galois.com committed
393 394 395 396
  matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
  return $ MatchGroup matches' ty

addTickMatch :: Bool -> Match Id -> TM (Match Id)
397 398 399 400
addTickMatch isOneOfMany (Match pats opSig gRHSs) =
  bindLocals (collectPatsBinders pats) $ do
    gRHSs' <- addTickGRHSs isOneOfMany gRHSs
    return $ Match pats opSig gRHSs'
andy@galois.com's avatar
andy@galois.com committed
401 402 403

addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
404
  bindLocals binders $ do
405
    local_binds' <- addTickHsLocalBinds local_binds
406 407 408
    guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
    return $ GRHSs guarded' local_binds'
  where
409
    binders = collectLocalBinders local_binds
andy@galois.com's avatar
andy@galois.com committed
410 411

addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id)
412
addTickGRHS isOneOfMany (GRHS stmts expr) = do
413
  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
414
                        (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr
415
                                    else addTickLHsExprAlways expr)
andy@galois.com's avatar
andy@galois.com committed
416 417
  return $ GRHS stmts' expr'

418 419
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts isGuard stmts = do
420 421 422 423 424 425
  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
  return stmts

addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a 
               -> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
426 427 428 429
  = bindLocals (collectLStmtsBinders lstmts) $ 
    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
       ; a <- res
       ; return (lstmts', a) }
430 431

addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
432 433 434 435
addTickStmt _isGuard (LastStmt e ret) = do
	liftM2 LastStmt
		(addTickLHsExprAlways e)
		(addTickSyntaxExpr hpcSrcSpan ret)
436
addTickStmt _isGuard (BindStmt pat e bind fail) = do
437
	liftM4 BindStmt
andy@galois.com's avatar
andy@galois.com committed
438
		(addTickLPat pat)
439
		(addTickLHsExprAlways e)
andy@galois.com's avatar
andy@galois.com committed
440 441
		(addTickSyntaxExpr hpcSrcSpan bind)
		(addTickSyntaxExpr hpcSrcSpan fail)
442 443
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
	liftM4 ExprStmt
444
		(addTick isGuard e)
andy@galois.com's avatar
andy@galois.com committed
445
		(addTickSyntaxExpr hpcSrcSpan bind')
446
		(addTickSyntaxExpr hpcSrcSpan guard')
andy@galois.com's avatar
andy@galois.com committed
447
		(return ty)
448
addTickStmt _isGuard (LetStmt binds) = do
449 450
	liftM LetStmt
		(addTickHsLocalBinds binds)
451 452
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
    liftM4 ParStmt 
453
        (mapM (addTickStmtAndBinders isGuard) pairs)
454 455 456 457 458 459 460 461 462 463 464 465
        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
        (addTickSyntaxExpr hpcSrcSpan bindExpr)
        (addTickSyntaxExpr hpcSrcSpan returnExpr)

addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr returnExpr bindExpr) = do
    t_s <- (addTickLStmts isGuard stmts)
    t_u <- (addTickLHsExprAlways usingExpr)
    t_m <- (addTickMaybeByLHsExpr maybeByExpr)
    t_r <- (addTickSyntaxExpr hpcSrcSpan returnExpr)
    t_b <- (addTickSyntaxExpr hpcSrcSpan bindExpr)
    return $ TransformStmt t_s ids t_u t_m t_r t_b

466 467 468 469 470 471 472 473 474 475 476 477
addTickStmt isGuard stmt@(GroupStmt { grpS_stmts = stmts
                                    , grpS_by = by, grpS_using = using
                                    , grpS_ret = returnExpr, grpS_bind = bindExpr
                                    , grpS_fmap = liftMExpr }) = do
    t_s <- addTickLStmts isGuard stmts
    t_y <- fmapMaybeM  addTickLHsExprAlways by
    t_u <- addTickLHsExprAlways using
    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
    return $ stmt { grpS_stmts = t_s, grpS_by = t_y, grpS_using = t_u
                  , grpS_ret = t_f, grpS_bind = t_b, grpS_fmap = t_m }
478

479 480 481 482 483 484
addTickStmt isGuard stmt@(RecStmt {})
  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
485
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
andy@galois.com's avatar
andy@galois.com committed
486

487
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
488 489 490
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                  | otherwise          = addTickLHsExprAlways e

491 492
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
                      -> TM ([LStmt Id], a)
493 494 495 496 497 498 499 500 501 502 503
addTickStmtAndBinders isGuard (stmts, ids) = 
    liftM2 (,) 
        (addTickLStmts isGuard stmts)
        (return ids)

addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
addTickMaybeByLHsExpr maybeByExpr = 
    case maybeByExpr of
        Nothing -> return Nothing
        Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)

andy@galois.com's avatar
andy@galois.com committed
504 505 506 507 508 509 510 511 512
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) = 
	liftM HsValBinds 
		(addTickHsValBinds binds)
addTickHsLocalBinds (HsIPBinds binds)  = 
	liftM HsIPBinds 
		(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds

513
addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
andy@galois.com's avatar
andy@galois.com committed
514 515 516 517 518 519 520 521
addTickHsValBinds (ValBindsOut binds sigs) =
	liftM2 ValBindsOut
		(mapM (\ (rec,binds') -> 
				liftM2 (,)
					(return rec)
					(addTickLHsBinds binds'))
			binds)
		(return sigs)
522
addTickHsValBinds _ = panic "addTickHsValBinds"
andy@galois.com's avatar
andy@galois.com committed
523

524
addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
andy@galois.com's avatar
andy@galois.com committed
525 526
addTickHsIPBinds (IPBinds ipbinds dictbinds) =
	liftM2 IPBinds
527
		(mapM (liftL (addTickIPBind)) ipbinds)
528
		(return dictbinds)
andy@galois.com's avatar
andy@galois.com committed
529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552

addTickIPBind :: IPBind Id -> TM (IPBind Id)
addTickIPBind (IPBind nm e) =
	liftM2 IPBind
		(return nm)
		(addTickLHsExpr e)

-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
addTickSyntaxExpr pos x = do
	L _ x' <- addTickLHsExpr (L pos x)
	return $ x'
-- we do not walk into patterns.
addTickLPat :: LPat Id -> TM (LPat Id)
addTickLPat pat = return pat

addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
	liftM4 HsCmdTop
		(addTickLHsCmd cmd)
		(return tys)
		(return ty)
		(return syntaxtable)

553
addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583
addTickLHsCmd (L pos c0) = do
        c1 <- addTickHsCmd c0
        return $ L pos c1 

addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
        liftM HsLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsApp e1 e2) = 
	liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
addTickHsCmd (OpApp e1 c2 fix c3) = 
	liftM4 OpApp 
		(addTickLHsExpr e1) 
		(addTickLHsCmd c2)
		(return fix)
		(addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
addTickHsCmd (HsCase e mgs) = 
	liftM2 HsCase
		(addTickLHsExpr e) 
		(addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) = 
	liftM3 (HsIf cnd)
		(addBinTickLHsExpr (BinBox CondBinBox) e1)
		(addTickLHsCmd c2)
		(addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
	bindLocals (collectLocalBinders binds) $
	liftM2 HsLet
		(addTickHsLocalBinds binds) -- to think about: !patterns.
                (addTickLHsCmd c)
584 585 586
addTickHsCmd (HsDo cxt stmts srcloc)
  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
       ; return (HsDo cxt stmts' srcloc) }
587

588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649
addTickHsCmd (HsArrApp	 e1 e2 ty1 arr_ty lr) = 
        liftM5 HsArrApp
	       (addTickLHsExpr e1)
	       (addTickLHsExpr e2)
	       (return ty1)
	       (return arr_ty)
	       (return lr)
addTickHsCmd (HsArrForm e fix cmdtop) = 
        liftM3 HsArrForm
	       (addTickLHsExpr e)
	       (return fix)
	       (mapM (liftL (addTickHsCmdTop)) cmdtop)

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

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

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

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

addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
addTickCmdGRHS (GRHS stmts cmd) = do
  (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
  return $ GRHS stmts' expr'

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

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

addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt (BindStmt pat c bind fail) = do
	liftM4 BindStmt
		(addTickLPat pat)
		(addTickLHsCmd c)
		(return bind)
		(return fail)
650 651
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
	liftM4 ExprStmt
652
		(addTickLHsCmd c)
653 654
		(addTickSyntaxExpr hpcSrcSpan bind')
                (addTickSyntaxExpr hpcSrcSpan guard')
655 656 657 658 659 660 661 662 663 664 665 666 667 668
		(return ty)
addTickCmdStmt (LetStmt binds) = do
	liftM LetStmt
		(addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {})
  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }

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

addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
671 672 673 674 675 676 677
addTickHsRecordBinds (HsRecFields fields dd) 
  = do	{ fields' <- mapM process fields
	; return (HsRecFields fields' dd) }
  where
    process (HsRecField ids expr doc)
	= do { expr' <- addTickLHsExpr expr
	     ; return (HsRecField ids expr' doc) }
andy@galois.com's avatar
andy@galois.com committed
678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698

addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
	liftM From
		(addTickLHsExpr e1)
addTickArithSeqInfo (FromThen e1 e2) =
	liftM2 FromThen
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickArithSeqInfo (FromTo e1 e2) =
	liftM2 FromTo
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
	liftM3 FromThenTo
		(addTickLHsExpr e1)
		(addTickLHsExpr e2)
		(addTickLHsExpr e3)
\end{code}

\begin{code}
699
data TickTransState = TT { tickBoxCount:: Int
700
                         , mixEntries  :: [MixEntry_]
andy@galois.com's avatar
andy@galois.com committed
701
                         }                        
702

703
data TickTransEnv = TTE { fileName      :: FastString
704
			, declPath     :: [String]
705
                        , inScope      :: VarSet
706
			, blackList   :: Map SrcSpan ()
707 708
			}

709
--	deriving Show
andy@galois.com's avatar
andy@galois.com committed
710

711
type FreeVars = OccEnv Id
712
noFVs :: FreeVars
713 714 715 716 717 718 719 720 721 722 723 724 725 726
noFVs = emptyOccEnv

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

727
data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
728 729
        -- a combination of a state monad (TickTransState) and a writer
        -- monad (FreeVars).
andy@galois.com's avatar
andy@galois.com committed
730 731

instance Monad TM where
732
  return a = TM $ \ _env st -> (a,noFVs,st)
733 734
  (TM m) >>= k = TM $ \ env st -> 
		                case m env st of
735
				  (r1,fv1,st1) -> 
736
                                     case unTM (k r1) env st1 of
737 738 739
                                       (r2,fv2,st2) -> 
                                          (r2, fv1 `plusOccEnv` fv2, st2)

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

743 744
-- setState :: (TickTransState -> TickTransState) -> TM ()
-- setState f = TM $ \ env st -> ((), noFVs, f st)
745

746 747 748 749 750 751
getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)

withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
withEnv f (TM m) = TM $ \ env st -> 
		                 case m (f env) st of
752 753 754 755
                                   (a, fvs, st') -> (a, fvs, st')

getFreeVars :: TM a -> TM (FreeVars, a)
getFreeVars (TM m) 
756
  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
757 758

freeVar :: Id -> TM ()
759
freeVar id = TM $ \ env st -> 
760
                if id `elemVarSet` inScope env
761 762
                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
                   else ((), noFVs, st)
andy@galois.com's avatar
andy@galois.com committed
763

764 765
addPathEntry :: String -> TM a -> TM a
addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
andy@galois.com's avatar
andy@galois.com committed
766 767

getPathEntry :: TM [String]
768
getPathEntry = declPath `liftM` getEnv
769

770 771 772 773 774 775
getFileName :: TM FastString
getFileName = fileName `liftM` getEnv

sameFileName :: SrcSpan -> TM a -> TM a -> TM a
sameFileName pos out_of_scope in_scope = do
  file_name <- getFileName
776
  case srcSpanFileName_maybe pos of 
777 778 779 780
    Just file_name2 
      | file_name == file_name2 -> in_scope
    _ -> out_of_scope

781 782
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
783
  = TM $ \ env st -> 
784
                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
785
                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
786
  where occs = [ nameOccName (idName id) | id <- new_ids ] 
andy@galois.com's avatar
andy@galois.com committed
787

788 789
isBlackListed :: SrcSpan -> TM Bool
isBlackListed pos = TM $ \ env st -> 
790
	      case Map.lookup pos (blackList env) of
791 792 793
	        Nothing -> (False,noFVs,st)
		Just () -> (True,noFVs,st)

andy@galois.com's avatar
andy@galois.com committed
794 795
-- the tick application inherits the source position of its
-- expression argument to support nested box allocations 
796
allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
797 798 799
allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 
  sameFileName pos 
    (do e <- m; return (L pos e)) $ do
800
  (fvs, e) <- getFreeVars m
Ian Lynagh's avatar
Ian Lynagh committed
801
  TM $ \ env st ->
802 803 804
    let c = tickBoxCount st
        ids = occEnvElts fvs
        mes = mixEntries st
Ian Lynagh's avatar
Ian Lynagh committed
805
        me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
806
    in
807 808 809 810
    ( L pos (HsTick c ids (L pos e))
    , fvs
    , st {tickBoxCount=c+1,mixEntries=me:mes}
    )
811
allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
andy@galois.com's avatar
andy@galois.com committed
812 813 814

-- the tick application inherits the source position of its
-- expression argument to support nested box allocations 
815
allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
816 817
allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
  sameFileName pos 
Ian Lynagh's avatar
Ian Lynagh committed
818
    (return Nothing) $ TM $ \ env st ->
819 820 821 822
  let mydecl_path
        | null (declPath env), TopLevelBox x <- boxLabel = x
        | otherwise = declPath env
      me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
andy@galois.com's avatar
andy@galois.com committed
823 824
      c = tickBoxCount st
      mes = mixEntries st
825
      ids = occEnvElts fvs
826
  in ( Just (c, ids)
827 828
     , noFVs
     , st {tickBoxCount=c+1, mixEntries=me:mes}
andy@galois.com's avatar
andy@galois.com committed
829
     )
830
allocATickBox _boxLabel _pos _fvs = return Nothing
andy@galois.com's avatar
andy@galois.com committed
831

832 833 834 835 836 837 838
allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
                -> TM (LHsExpr Id)
allocBinTickBox boxLabel pos m
 | not opt_Hpc = allocTickBox (ExpBox False) pos m
 | isGoodSrcSpan' pos =
 do
 e <- m
Ian Lynagh's avatar
Ian Lynagh committed
839 840 841 842
 TM $ \ env st ->
  let meT = (pos,declPath env, [],boxLabel True)
      meF = (pos,declPath env, [],boxLabel False)
      meE = (pos,declPath env, [],ExpBox False)
andy@galois.com's avatar
andy@galois.com committed
843 844
      c = tickBoxCount st
      mes = mixEntries st
845
  in 
846
             ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
847 848 849
           -- notice that F and T are reversed,
           -- because we are building the list in
           -- reverse...
850 851
             , noFVs
             , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
852
             )
853
allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
andy@galois.com's avatar
andy@galois.com committed
854

855
isGoodSrcSpan' :: SrcSpan -> Bool
856 857 858 859 860 861 862 863 864
isGoodSrcSpan' pos
   | not (isGoodSrcSpan pos) = False
   | start == end            = False
   | otherwise		     = True
  where
   start = srcSpanStart pos
   end   = srcSpanEnd pos

mkHpcPos :: SrcSpan -> HpcPos
andy@galois.com's avatar
andy@galois.com committed
865
mkHpcPos pos 
866 867
   | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
   | otherwise		      = hpcPos
andy@galois.com's avatar
andy@galois.com committed
868 869 870 871
  where
   start = srcSpanStart pos
   end   = srcSpanEnd pos
   hpcPos = toHpcPos ( srcLocLine start
872
		     , srcLocCol start
andy@galois.com's avatar
andy@galois.com committed
873
		     , srcLocLine end
874
		     , srcLocCol end - 1
andy@galois.com's avatar
andy@galois.com committed
875 876
		     )

877
hpcSrcSpan :: SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
878
hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
andy@galois.com's avatar
andy@galois.com committed
879 880 881
\end{code}


882 883 884 885 886 887 888 889
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
  where
	matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
\end{code}


andy@galois.com's avatar
andy@galois.com committed
890
\begin{code}
891
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
892 893 894 895 896 897 898

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

899
mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
900 901
mixHash file tm tabstop entries = fromIntegral $ hashString
	(show $ Mix file tm 0 tabstop entries)
andy@galois.com's avatar
andy@galois.com committed
902
\end{code}
903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955

%************************************************************************
%*									*
%*              initialisation
%*									*
%************************************************************************

Each module compiled with -fhpc declares an initialisation function of
the form `hpc_init_<module>()`, which is emitted into the _stub.c file
and annotated with __attribute__((constructor)) so that it gets
executed at startup time.

The function's purpose is to call hs_hpc_module to register this
module with the RTS, and it looks something like this:

static void hpc_init_Main(void) __attribute__((constructor));
static void hpc_init_Main(void)
{extern StgWord64 _hpc_tickboxes_Main_hpc[];
 hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}

\begin{code}
hpcInitCode :: Module -> HpcInfo -> SDoc
hpcInitCode _ (NoHpcInfo {}) = empty
hpcInitCode this_mod (HpcInfo tickCount hashNo)
 = vcat
    [ text "static void hpc_init_" <> ppr this_mod
         <> text "(void) __attribute__((constructor));"
    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
    , braces (vcat [
        ptext (sLit "extern StgWord64 ") <> tickboxes <>
               ptext (sLit "[]") <> semi,
        ptext (sLit "hs_hpc_module") <>
          parens (hcat (punctuate comma [
              doubleQuotes full_name_str,
              int tickCount, -- really StgWord32
              int hashNo,    -- really StgWord32
              tickboxes
            ])) <> semi
       ])
    ]
  where
    tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)

    module_name  = hcat (map (text.charToC) $
                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
    package_name = hcat (map (text.charToC) $
                         bytesFS (packageIdFS  (modulePackageId this_mod)))
    full_name_str
       | modulePackageId this_mod == mainPackageId
       = module_name
       | otherwise
       = package_name <> char '/' <> module_name
\end{code}