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