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