X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=72c9e664f321c379c2769f1e5a5455c9f2fb3f3f;hb=3e09edbc9e9c2bd8b0fddc946ce28014881cbfa1;hp=6bdc8a178ca4fbf3aeaa19f0070d27efe9e1de45;hpb=f1cc3eb980a634e62f2739a7a25387c902fa9d8a;p=ghc-hetmet.git diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 6bdc8a1..72c9e66 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -23,7 +23,6 @@ import FastString import HscTypes import StaticFlags import TyCon -import FiniteMap import MonadUtils import Maybes @@ -35,6 +34,8 @@ import Trace.Hpc.Util import BreakArray import Data.HashTable ( hashString ) +import Data.Map (Map) +import qualified Data.Map as Map \end{code} @@ -76,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = { fileName = mkFastString orig_file2 , declPath = [] , inScope = emptyVarSet - , blackList = listToFM [ (getSrcSpan (tyConName tyCon),()) - | tyCon <- tyCons ] + , blackList = Map.fromList [ (getSrcSpan (tyConName tyCon),()) + | tyCon <- tyCons ] }) (TT { tickBoxCount = 0 @@ -98,7 +99,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = createDirectoryIfMissing True hpc_mod_dir modTime <- getModificationTime orig_file2 let entries' = [ (hpcPos, box) - | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ] + | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] when (length entries' /= tickBoxCount st) $ do panic "the number of .mix entries are inconsistent" let hashNo = mixHash orig_file2 modTime tabStop entries' @@ -112,13 +113,16 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = breakArray <- newBreakArray $ length entries let locsTicks = listArray (0,tickBoxCount st-1) - [ span | (span,_,_) <- entries ] + [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,tickBoxCount st-1) - [ vars | (_,vars,_) <- entries ] + [ vars | (_,_,vars,_) <- entries ] + declsTicks= listArray (0,tickBoxCount st-1) + [ decls | (_,decls,_,_) <- entries ] modBreaks = emptyModBreaks { modBreaks_flags = breakArray , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks } doIfSet_dyn dflags Opt_D_dump_hpc $ do @@ -138,9 +142,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) addTickLHsBinds binds = mapBagM addTickLHsBind binds addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) -addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do - abs_binds' <- addTickLHsBinds abs_binds - return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds' +addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do + binds' <- addTickLHsBinds binds + return $ L pos $ bind { abs_binds = binds' } addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do let name = getOccString id decl_path <- getPathEntry @@ -285,8 +289,8 @@ addTickHsExpr (HsCase e mgs) = liftM2 HsCase (addTickLHsExpr e) (addTickMatchGroup mgs) -addTickHsExpr (HsIf e1 e2 e3) = - liftM3 HsIf +addTickHsExpr (HsIf cnd e1 e2 e3) = + liftM3 (HsIf cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) @@ -461,7 +465,7 @@ addTickStmt isGuard stmt@(RecStmt {}) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; dicts' <- addTickDictBinds (recS_dicts stmt) + ; dicts' <- addTickEvBinds (recS_dicts stmt) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' , recS_mfix_fn = mfix', recS_bind_fn = bind' , recS_dicts = dicts' }) } @@ -507,7 +511,7 @@ addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id) addTickHsIPBinds (IPBinds ipbinds dictbinds) = liftM2 IPBinds (mapM (liftL (addTickIPBind)) ipbinds) - (addTickDictBinds dictbinds) + (return dictbinds) addTickIPBind :: IPBind Id -> TM (IPBind Id) addTickIPBind (IPBind nm e) = @@ -535,8 +539,8 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) addTickLHsCmd x = addTickLHsExpr x -addTickDictBinds :: DictBinds Id -> TM (DictBinds Id) -addTickDictBinds x = addTickLHsBinds x +addTickEvBinds :: TcEvBinds -> TM TcEvBinds +addTickEvBinds x = return x -- No coverage testing for dictionary binding addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) addTickHsRecordBinds (HsRecFields fields dd) @@ -574,7 +578,7 @@ data TickTransState = TT { tickBoxCount:: Int data TickTransEnv = TTE { fileName :: FastString , declPath :: [String] , inScope :: VarSet - , blackList :: FiniteMap SrcSpan () + , blackList :: Map SrcSpan () } -- deriving Show @@ -658,7 +662,7 @@ bindLocals new_ids (TM m) isBlackListed :: SrcSpan -> TM Bool isBlackListed pos = TM $ \ env st -> - case lookupFM (blackList env) pos of + case Map.lookup pos (blackList env) of Nothing -> (False,noFVs,st) Just () -> (True,noFVs,st) @@ -669,11 +673,11 @@ allocTickBox boxLabel pos m | isGoodSrcSpan' pos = sameFileName pos (do e <- m; return (L pos e)) $ do (fvs, e) <- getFreeVars m - TM $ \ _env st -> + TM $ \ env st -> let c = tickBoxCount st ids = occEnvElts fvs mes = mixEntries st - me = (pos, map (nameOccName.idName) ids, boxLabel) + me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel) in ( L pos (HsTick c ids (L pos e)) , fvs @@ -686,8 +690,11 @@ allocTickBox _boxLabel pos m = do e <- m; return (L pos e) allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id])) allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = sameFileName pos - (return Nothing) $ TM $ \ _env st -> - let me = (pos, map (nameOccName.idName) ids, boxLabel) + (return Nothing) $ TM $ \ env st -> + let mydecl_path + | null (declPath env), TopLevelBox x <- boxLabel = x + | otherwise = declPath env + me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel) c = tickBoxCount st mes = mixEntries st ids = occEnvElts fvs @@ -704,10 +711,10 @@ allocBinTickBox boxLabel pos m | isGoodSrcSpan' pos = do e <- m - TM $ \ _env st -> - let meT = (pos,[],boxLabel True) - meF = (pos,[],boxLabel False) - meE = (pos,[],ExpBox False) + TM $ \ env st -> + let meT = (pos,declPath env, [],boxLabel True) + meF = (pos,declPath env, [],boxLabel False) + meE = (pos,declPath env, [],ExpBox False) c = tickBoxCount st mes = mixEntries st in @@ -756,7 +763,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 \begin{code} -type MixEntry_ = (SrcSpan, [OccName], BoxLabel) +type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) -- For the hash value, we hash everything: the file name, -- the timestamp of the original source file, the tab stop,