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 srcloc)
 305   = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
 306        ; return (HsDo cxt stmts' srcloc) }
 307   where
 308         forQual = case cxt of
 309                     ListComp -> Just $ BinBox QualBinBox
 310                     _        -> Nothing
 311 addTickHsExpr (ExplicitList ty es) =
 312         liftM2 ExplicitList
 313                 (return ty)
 314                 (mapM (addTickLHsExpr) es)
 315 addTickHsExpr (ExplicitPArr ty es) =
 316         liftM2 ExplicitPArr
 317                 (return ty)
 318                 (mapM (addTickLHsExpr) es)
 319 addTickHsExpr (RecordCon id ty rec_binds) =
 320         liftM3 RecordCon
 321                 (return id)
 322                 (return ty)
 323                 (addTickHsRecordBinds rec_binds)
 324 addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
 325         liftM5 RecordUpd
 326                 (addTickLHsExpr e)
 327                 (addTickHsRecordBinds rec_binds)
 328                 (return cons) (return tys1) (return tys2)
 329
 330 addTickHsExpr (ExprWithTySigOut e ty) =
 331         liftM2 ExprWithTySigOut
 332                 (addTickLHsExprNever e) -- No need to tick the inner expression
 333                                     -- for expressions with signatures
 334                 (return ty)
 335 addTickHsExpr (ArithSeq  ty arith_seq) =
 336         liftM2 ArithSeq
 337                 (return ty)
 338                 (addTickArithSeqInfo arith_seq)
 339 addTickHsExpr (HsTickPragma _ (L pos e0)) = do
 340     e2 <- allocTickBox (ExpBox False) pos $
 341                 addTickHsExpr e0
 342     return $ unLoc e2
 343 addTickHsExpr (PArrSeq   ty arith_seq) =
 344         liftM2 PArrSeq
 345                 (return ty)
 346                 (addTickArithSeqInfo arith_seq)
 347 addTickHsExpr (HsSCC nm e) =
 348         liftM2 HsSCC
 349                 (return nm)
 350                 (addTickLHsExpr e)
 351 addTickHsExpr (HsCoreAnn nm e) =
 352         liftM2 HsCoreAnn
 353                 (return nm)
 354                 (addTickLHsExpr e)
 355 addTickHsExpr e@(HsBracket     {}) = return e
 356 addTickHsExpr e@(HsBracketOut  {}) = return e
 357 addTickHsExpr e@(HsSpliceE  {}) = return e
 358 addTickHsExpr (HsProc pat cmdtop) =
 359         liftM2 HsProc
 360                 (addTickLPat pat)
 361                 (liftL (addTickHsCmdTop) cmdtop)
 362 addTickHsExpr (HsWrap w e) =
 363         liftM2 HsWrap
 364                 (return w)
 365                 (addTickHsExpr e)       -- explicitly no tick on inside
 366
 367 addTickHsExpr (HsArrApp  e1 e2 ty1 arr_ty lr) =
 368         liftM5 HsArrApp
 369                (addTickLHsExpr e1)
 370                (addTickLHsExpr e2)
 371                (return ty1)
 372                (return arr_ty)
 373                (return lr)
 374
 375 addTickHsExpr (HsArrForm e fix cmdtop) =
 376         liftM3 HsArrForm
 377                (addTickLHsExpr e)
 378                (return fix)
 379                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 380
 381 addTickHsExpr e@(HsType _) = return e
 382
 383 -- Others dhould never happen in expression content.
 384 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
 385
 386 addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
 387 addTickTupArg (Present e)  = do { e' <- addTickLHsExpr e; return (Present e') }
 388 addTickTupArg (Missing ty) = return (Missing ty)
 389
 390 addTickMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
 391 addTickMatchGroup (MatchGroup matches ty) = do
 392   let isOneOfMany = matchesOneOfMany matches
 393   matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
 394   return $ MatchGroup matches' ty
 395
 396 addTickMatch :: Bool -> Match Id -> TM (Match Id)
 397 addTickMatch isOneOfMany (Match pats opSig gRHSs) =
 398   bindLocals (collectPatsBinders pats) $ do
 399     gRHSs' <- addTickGRHSs isOneOfMany gRHSs
 400     return $ Match pats opSig gRHSs'
 401
 402 addTickGRHSs :: Bool -> GRHSs Id -> TM (GRHSs Id)
 403 addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do
 404   bindLocals binders $ do
 405     local_binds' <- addTickHsLocalBinds local_binds
 406     guarded' <- mapM (liftL (addTickGRHS isOneOfMany)) guarded
 407     return $ GRHSs guarded' local_binds'
 408   where
 409     binders = collectLocalBinders local_binds
 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)
 416   return $ GRHS stmts' expr'
 417
 418 addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
 419 addTickLStmts isGuard stmts = do
 420   (stmts, _) <- addTickLStmts' isGuard stmts (return ())
 421   return stmts
 422
 423 addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
 424                -> TM ([LStmt Id], a)
 425 addTickLStmts' isGuard lstmts res
 426   = bindLocals (collectLStmtsBinders lstmts) $
 427     do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
 428        ; a <- res
 429        ; return (lstmts', a) }
 430
 431 addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
 432 addTickStmt _isGuard (LastStmt e ret) = do
 433         liftM2 LastStmt
 434                 (addTickLHsExprAlways e)
 435                 (addTickSyntaxExpr hpcSrcSpan ret)
 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 stmt@(GroupStmt { grpS_stmts = stmts
 467                                     , grpS_by = by, grpS_using = using
 468                                     , grpS_ret = returnExpr, grpS_bind = bindExpr
 469                                     , grpS_fmap = liftMExpr }) = do
 470     t_s <- addTickLStmts isGuard stmts
 471     t_y <- fmapMaybeM  addTickLHsExprAlways by
 472     t_u <- addTickLHsExprAlways using
 473     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
 474     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
 475     t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
 476     return $ stmt { grpS_stmts = t_s, grpS_by = t_y, grpS_using = t_u
 477                   , grpS_ret = t_f, grpS_bind = t_b, grpS_fmap = t_m }
 478
 479 addTickStmt isGuard stmt@(RecStmt {})
 480   = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
 481        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
 482        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
 483        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
 484        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
 485                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 486
 487 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 488 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
 489                   | otherwise          = addTickLHsExprAlways e
 490
 491 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a)
 492                       -> TM ([LStmt Id], a)
 493 addTickStmtAndBinders isGuard (stmts, ids) =
 494     liftM2 (,)
 495         (addTickLStmts isGuard stmts)
 496         (return ids)
 497
 498 addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
 499 addTickMaybeByLHsExpr maybeByExpr =
 500     case maybeByExpr of
 501         Nothing -> return Nothing
 502         Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
 503
 504 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 505 addTickHsLocalBinds (HsValBinds binds) =
 506         liftM HsValBinds
 507                 (addTickHsValBinds binds)
 508 addTickHsLocalBinds (HsIPBinds binds)  =
 509         liftM HsIPBinds
 510                 (addTickHsIPBinds binds)
 511 addTickHsLocalBinds (EmptyLocalBinds)  = return EmptyLocalBinds
 512
 513 addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)
 514 addTickHsValBinds (ValBindsOut binds sigs) =
 515         liftM2 ValBindsOut
 516                 (mapM (\ (rec,binds') ->
 517                                 liftM2 (,)
 518                                         (return rec)
 519                                         (addTickLHsBinds binds'))
 520                         binds)
 521                 (return sigs)
 522 addTickHsValBinds _ = panic "addTickHsValBinds"
 523
 524 addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 525 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 526         liftM2 IPBinds
 527                 (mapM (liftL (addTickIPBind)) ipbinds)
 528                 (return dictbinds)
 529
 530 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 531 addTickIPBind (IPBind nm e) =
 532         liftM2 IPBind
 533                 (return nm)
 534                 (addTickLHsExpr e)
 535
 536 -- There is no location here, so we might need to use a context location??
 537 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
 538 addTickSyntaxExpr pos x = do
 539         L _ x' <- addTickLHsExpr (L pos x)
 540         return $ x'
 541 -- we do not walk into patterns.
 542 addTickLPat :: LPat Id -> TM (LPat Id)
 543 addTickLPat pat = return pat
 544
 545 addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)
 546 addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 547         liftM4 HsCmdTop
 548                 (addTickLHsCmd cmd)
 549                 (return tys)
 550                 (return ty)
 551                 (return syntaxtable)
 552
 553 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 554 addTickLHsCmd (L pos c0) = do
 555         c1 <- addTickHsCmd c0
 556         return $ L pos c1
 557
 558 addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
 559 addTickHsCmd (HsLam matchgroup) =
 560         liftM HsLam (addTickCmdMatchGroup matchgroup)
 561 addTickHsCmd (HsApp e1 e2) =
 562         liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)
 563 addTickHsCmd (OpApp e1 c2 fix c3) =
 564         liftM4 OpApp
 565                 (addTickLHsExpr e1)
 566                 (addTickLHsCmd c2)
 567                 (return fix)
 568                 (addTickLHsCmd c3)
 569 addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
 570 addTickHsCmd (HsCase e mgs) =
 571         liftM2 HsCase
 572                 (addTickLHsExpr e)
 573                 (addTickCmdMatchGroup mgs)
 574 addTickHsCmd (HsIf cnd e1 c2 c3) =
 575         liftM3 (HsIf cnd)
 576                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
 577                 (addTickLHsCmd c2)
 578                 (addTickLHsCmd c3)
 579 addTickHsCmd (HsLet binds c) =
 580         bindLocals (collectLocalBinders binds) $
 581         liftM2 HsLet
 582                 (addTickHsLocalBinds binds) -- to think about: !patterns.
 583                 (addTickLHsCmd c)
 584 addTickHsCmd (HsDo cxt stmts srcloc)
 585   = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
 586        ; return (HsDo cxt stmts' srcloc) }
 587
 588 addTickHsCmd (HsArrApp   e1 e2 ty1 arr_ty lr) =
 589         liftM5 HsArrApp
 590                (addTickLHsExpr e1)
 591                (addTickLHsExpr e2)
 592                (return ty1)
 593                (return arr_ty)
 594                (return lr)
 595 addTickHsCmd (HsArrForm e fix cmdtop) =
 596         liftM3 HsArrForm
 597                (addTickLHsExpr e)
 598                (return fix)
 599                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 600
 601 -- Others should never happen in a command context.
 602 addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
 603
 604 addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
 605 addTickCmdMatchGroup (MatchGroup matches ty) = do
 606   matches' <- mapM (liftL addTickCmdMatch) matches
 607   return $ MatchGroup matches' ty
 608
 609 addTickCmdMatch :: Match Id -> TM (Match Id)
 610 addTickCmdMatch (Match pats opSig gRHSs) =
 611   bindLocals (collectPatsBinders pats) $ do
 612     gRHSs' <- addTickCmdGRHSs gRHSs
 613     return $ Match pats opSig gRHSs'
 614
 615 addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
 616 addTickCmdGRHSs (GRHSs guarded local_binds) = do
 617   bindLocals binders $ do
 618     local_binds' <- addTickHsLocalBinds local_binds
 619     guarded' <- mapM (liftL addTickCmdGRHS) guarded
 620     return $ GRHSs guarded' local_binds'
 621   where
 622     binders = collectLocalBinders local_binds
 623
 624 addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
 625 addTickCmdGRHS (GRHS stmts cmd) = do
 626   (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
 627   return $ GRHS stmts' expr'
 628
 629 addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
 630 addTickLCmdStmts stmts = do
 631   (stmts, _) <- addTickLCmdStmts' stmts (return ())
 632   return stmts
 633
 634 addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
 635 addTickLCmdStmts' lstmts res
 636   = bindLocals binders $ do
 637         lstmts' <- mapM (liftL addTickCmdStmt) lstmts
 638         a <- res
 639         return (lstmts', a)
 640   where
 641         binders = collectLStmtsBinders lstmts
 642
 643 addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
 644 addTickCmdStmt (BindStmt pat c bind fail) = do
 645         liftM4 BindStmt
 646                 (addTickLPat pat)
 647                 (addTickLHsCmd c)
 648                 (return bind)
 649                 (return fail)
 650 addTickCmdStmt (ExprStmt c bind' guard' ty) = do
 651         liftM4 ExprStmt
 652                 (addTickLHsCmd c)
 653                 (addTickSyntaxExpr hpcSrcSpan bind')
 654                 (addTickSyntaxExpr hpcSrcSpan guard')
 655                 (return ty)
 656 addTickCmdStmt (LetStmt binds) = do
 657         liftM LetStmt
 658                 (addTickHsLocalBinds binds)
 659 addTickCmdStmt stmt@(RecStmt {})
 660   = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
 661        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
 662        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
 663        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
 664        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
 665                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 666
 667 -- Others should never happen in a command context.
 668 addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
 669
 670 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 671 addTickHsRecordBinds (HsRecFields fields dd)
 672   = do  { fields' <- mapM process fields
 673         ; return (HsRecFields fields' dd) }
 674   where
 675     process (HsRecField ids expr doc)
 676         = do { expr' <- addTickLHsExpr expr
 677              ; return (HsRecField ids expr' doc) }
 678
 679 addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
 680 addTickArithSeqInfo (From e1) =
 681         liftM From
 682                 (addTickLHsExpr e1)
 683 addTickArithSeqInfo (FromThen e1 e2) =
 684         liftM2 FromThen
 685                 (addTickLHsExpr e1)
 686                 (addTickLHsExpr e2)
 687 addTickArithSeqInfo (FromTo e1 e2) =
 688         liftM2 FromTo
 689                 (addTickLHsExpr e1)
 690                 (addTickLHsExpr e2)
 691 addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 692         liftM3 FromThenTo
 693                 (addTickLHsExpr e1)
 694                 (addTickLHsExpr e2)
 695                 (addTickLHsExpr e3)
 696 \end{code}
 697
 698 \begin{code}
 699 data TickTransState = TT { tickBoxCount:: Int
 700                          , mixEntries  :: [MixEntry_]
 701                          }
 702
 703 data TickTransEnv = TTE { fileName      :: FastString
 704                         , declPath     :: [String]
 705                         , inScope      :: VarSet
 706                         , blackList   :: Map SrcSpan ()
 707                         }
 708
 709 --      deriving Show
 710
 711 type FreeVars = OccEnv Id
 712 noFVs :: FreeVars
 713 noFVs = emptyOccEnv
 714
 715 -- Note [freevars]
 716 --   For breakpoints we want to collect the free variables of an
 717 --   expression for pinning on the HsTick.  We don't want to collect
 718 --   *all* free variables though: in particular there's no point pinning
 719 --   on free variables that are will otherwise be in scope at the GHCi
 720 --   prompt, which means all top-level bindings.  Unfortunately detecting
 721 --   top-level bindings isn't easy (collectHsBindsBinders on the top-level
 722 --   bindings doesn't do it), so we keep track of a set of "in-scope"
 723 --   variables in addition to the free variables, and the former is used
 724 --   to filter additions to the latter.  This gives us complete control
 725 --   over what free variables we track.
 726
 727 data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
 728         -- a combination of a state monad (TickTransState) and a writer
 729         -- monad (FreeVars).
 730
 731 instance Monad TM where
 732   return a = TM $ \ _env st -> (a,noFVs,st)
 733   (TM m) >>= k = TM $ \ env st ->
 734                                 case m env st of
 735                                   (r1,fv1,st1) ->
 736                                      case unTM (k r1) env st1 of
 737                                        (r2,fv2,st2) ->
 738                                           (r2, fv1 `plusOccEnv` fv2, st2)
 739
 740 -- getState :: TM TickTransState
 741 -- getState = TM $ \ env st -> (st, noFVs, st)
 742
 743 -- setState :: (TickTransState -> TickTransState) -> TM ()
 744 -- setState f = TM $ \ env st -> ((), noFVs, f st)
 745
 746 getEnv :: TM TickTransEnv
 747 getEnv = TM $ \ env st -> (env, noFVs, st)
 748
 749 withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
 750 withEnv f (TM m) = TM $ \ env st ->
 751                                  case m (f env) st of
 752                                    (a, fvs, st') -> (a, fvs, st')
 753
 754 getFreeVars :: TM a -> TM (FreeVars, a)
 755 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                    then ((), unitOccEnv (nameOccName (idName id)) id, st)
 762                    else ((), noFVs, st)
 763
 764 addPathEntry :: String -> TM a -> TM a
 765 addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
 766
 767 getPathEntry :: TM [String]
 768 getPathEntry = declPath `liftM` getEnv
 769
 770 getFileName :: TM FastString
 771 getFileName = fileName `liftM` getEnv
 772
 773 sameFileName :: SrcSpan -> TM a -> TM a -> TM a
 774 sameFileName pos out_of_scope in_scope = do
 775   file_name <- getFileName
 776   case srcSpanFileName_maybe pos of
 777     Just file_name2
 778       | file_name == file_name2 -> in_scope
 779     _ -> out_of_scope
 780
 781 bindLocals :: [Id] -> TM a -> TM a
 782 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 ]
 787
 788 isBlackListed :: SrcSpan -> TM Bool
 789 isBlackListed pos = TM $ \ env st ->
 790               case Map.lookup pos (blackList env) of
 791                 Nothing -> (False,noFVs,st)
 792                 Just () -> (True,noFVs,st)
 793
 794 -- the tick application inherits the source position of its
 795 -- expression argument to support nested box allocations
 796 allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id)
 797 allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
 798   sameFileName pos
 799     (do e <- m; return (L pos e)) $ do
 800   (fvs, e) <- getFreeVars m
 801   TM $ \ env st ->
 802     let c = tickBoxCount st
 803         ids = occEnvElts fvs
 804         mes = mixEntries st
 805         me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
 806     in
 807     ( L pos (HsTick c ids (L pos e))
 808     , fvs
 809     , st {tickBoxCount=c+1,mixEntries=me:mes}
 810     )
 811 allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
 812
 813 -- the tick application inherits the source position of its
 814 -- expression argument to support nested box allocations
 815 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 816 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
 817   sameFileName pos
 818     (return Nothing) $ TM $ \ env st ->
 819   let mydecl_path
 820         | null (declPath env), TopLevelBox x <- boxLabel = x
 821         | otherwise = declPath env
 822       me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
 823       c = tickBoxCount st
 824       mes = mixEntries st
 825       ids = occEnvElts fvs
 826   in ( Just (c, ids)
 827      , noFVs
 828      , st {tickBoxCount=c+1, mixEntries=me:mes}
 829      )
 830 allocATickBox _boxLabel _pos _fvs = return Nothing
 831
 832 allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)
 833                 -> TM (LHsExpr Id)
 834 allocBinTickBox boxLabel pos m
 835  | not opt_Hpc = allocTickBox (ExpBox False) pos m
 836  | isGoodSrcSpan' pos =
 837  do
 838  e <- m
 839  TM $ \ env st ->
 840   let meT = (pos,declPath env, [],boxLabel True)
 841       meF = (pos,declPath env, [],boxLabel False)
 842       meE = (pos,declPath env, [],ExpBox False)
 843       c = tickBoxCount st
 844       mes = mixEntries st
 845   in
 846              ( L pos $ HsTick c [] $ L pos $ HsBinTick (c+1) (c+2) (L pos e)
 847            -- notice that F and T are reversed,
 848            -- because we are building the list in
 849            -- reverse...
 850              , noFVs
 851              , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
 852              )
 853 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
 854
 855 isGoodSrcSpan' :: SrcSpan -> Bool
 856 isGoodSrcSpan' pos
 857    | not (isGoodSrcSpan pos) = False
 858    | start == end            = False
 859    | otherwise               = True
 860   where
 861    start = srcSpanStart pos
 862    end   = srcSpanEnd pos
 863
 864 mkHpcPos :: SrcSpan -> HpcPos
 865 mkHpcPos pos
 866    | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
 867    | otherwise                = hpcPos
 868   where
 869    start = srcSpanStart pos
 870    end   = srcSpanEnd pos
 871    hpcPos = toHpcPos ( srcLocLine start
 872                      , srcLocCol start
 873                      , srcLocLine end
 874                      , srcLocCol end - 1
 875                      )
 876
 877 hpcSrcSpan :: SrcSpan
 878 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
 879 \end{code}
 880
 881
 882 \begin{code}
 883 matchesOneOfMany :: [LMatch Id] -> Bool
 884 matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 885   where
 886         matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
 887 \end{code}
 888
 889
 890 \begin{code}
 891 type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 892
 893 -- For the hash value, we hash everything: the file name,
 894 --  the timestamp of the original source file, the tab stop,
 895 --  and the mix entries. We cheat, and hash the show'd string.
 896 -- This hash only has to be hashed at Mix creation time,
 897 -- and is for sanity checking only.
 898
 899 mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
 900 mixHash file tm tabstop entries = fromIntegral $ hashString
 901         (show $ Mix file tm 0 tabstop entries)
 902 \end{code}
 903
 904 %************************************************************************
 905 %*                                                                      *
 906 %*              initialisation
 907 %*                                                                      *
 908 %************************************************************************
 909
 910 Each module compiled with -fhpc declares an initialisation function of
 911 the form `hpc_init_<module>()`, which is emitted into the _stub.c file
 912 and annotated with __attribute__((constructor)) so that it gets
 913 executed at startup time.
 914
 915 The function's purpose is to call hs_hpc_module to register this
 916 module with the RTS, and it looks something like this:
 917
 918 static void hpc_init_Main(void) __attribute__((constructor));
 919 static void hpc_init_Main(void)
 920 {extern StgWord64 _hpc_tickboxes_Main_hpc[];
 921  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
 922
 923 \begin{code}
 924 hpcInitCode :: Module -> HpcInfo -> SDoc
 925 hpcInitCode _ (NoHpcInfo {}) = empty
 926 hpcInitCode this_mod (HpcInfo tickCount hashNo)
 927  = vcat
 928     [ text "static void hpc_init_" <> ppr this_mod
 929          <> text "(void) __attribute__((constructor));"
 930     , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
 931     , braces (vcat [
 932         ptext (sLit "extern StgWord64 ") <> tickboxes <>
 933                ptext (sLit "[]") <> semi,
 934         ptext (sLit "hs_hpc_module") <>
 935           parens (hcat (punctuate comma [
 936               doubleQuotes full_name_str,
 937               int tickCount, -- really StgWord32
 938               int hashNo,    -- really StgWord32
 939               tickboxes
 940             ])) <> semi
 941        ])
 942     ]
 943   where
 944     tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod)
 945
 946     module_name  = hcat (map (text.charToC) $
 947                          bytesFS (moduleNameFS (Module.moduleName this_mod)))
 948     package_name = hcat (map (text.charToC) $
 949                          bytesFS (packageIdFS  (modulePackageId this_mod)))
 950     full_name_str
 951        | modulePackageId this_mod == mainPackageId
 952        = module_name
 953        | otherwise
 954        = package_name <> char '/' <> module_name
 955 \end{code}