X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=7b58a95e083c86bdd149867229a8f943de90114a;hb=aafdba3bce91afb003f5f50e001e141744837bae;hp=3a3b7458f18a794ee0c5e9c9638e8ae149594443;hpb=596cacfe4e9463d1fd66c3292bef7432cfb1b17a;p=ghc-hetmet.git diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 3a3b745..7b58a95 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -5,6 +5,13 @@ \section[Coverage]{@coverage@: the main function} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Coverage (addCoverageTicksToBinds) where #include "HsVersions.h" @@ -44,7 +51,6 @@ import Trace.Hpc.Util import BreakArray import Data.HashTable ( hashString ) - \end{code} @@ -82,7 +88,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do , inScope = emptyVarSet , blackList = listToFM [ (getSrcSpan (tyConName tyCon),()) | tyCon <- tyCons ] - , declBlock = noSrcSpan }) + }) (TT { tickBoxCount = 0 , mixEntries = [] @@ -102,7 +108,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do createDirectoryIfMissing True hpc_mod_dir modTime <- getModificationTime orig_file 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_file modTime tabStop entries' @@ -116,16 +122,13 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 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 ] - declsTicks = listArray (0,tickBoxCount st-1) - [ decls| (_,_,_,decls) <- entries ] + [ vars | (_,vars,_) <- entries ] modBreaks = emptyModBreaks { modBreaks_flags = breakArray , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks } doIfSet_dyn dflags Opt_D_dump_hpc $ do @@ -154,7 +157,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do (fvs, mg@(MatchGroup matches' ty)) <- getFreeVars $ - addPathEntry name pos $ + addPathEntry name $ addTickMatchGroup (fun_matches funBind) blackListed <- isBlackListed pos @@ -183,7 +186,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do let name = "(...)" - rhs' <- addPathEntry name pos $ addTickGRHSs False rhs + rhs' <- addPathEntry name $ addTickGRHSs False rhs {- decl_path <- getPathEntry tick_me <- allocTickBox (if null decl_path @@ -192,12 +195,8 @@ addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do -} return $ L pos $ pat { pat_rhs = rhs' } -{- only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind (VarBind var_id var_rhs) = do - var_rhs' <- addTickLHsExpr var_rhs - return $ VarBind var_id var_rhs' --} -addTickLHsBind other = return other +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind -- Add a tick to the expression no matter what it is. There is one exception: -- for the debugger, if the expression is a 'let', then we don't want to add @@ -413,10 +412,10 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do binders = map unLoc (collectLocalBinders local_binds) addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id) -addTickGRHS isOneOfMany (GRHS stmts expr@(L pos _)) = do +addTickGRHS isOneOfMany (GRHS stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr - else addPathEntry "" pos $ addTickLHsExprAlways expr) + else addTickLHsExprAlways expr) return $ GRHS stmts' expr' addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id] @@ -557,7 +556,6 @@ data TickTransEnv = TTE { fileName :: FastString , declPath :: [String] , inScope :: VarSet , blackList :: FiniteMap SrcSpan () - , declBlock :: SrcSpan } -- deriving Show @@ -614,8 +612,8 @@ freeVar id = TM $ \ env st -> then ((), unitOccEnv (nameOccName (idName id)) id, st) else ((), noFVs, st) -addPathEntry :: String -> SrcSpan -> TM a -> TM a -addPathEntry nm src = withEnv (\ env -> env { declPath = declPath env ++ [nm], declBlock = src }) +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) getPathEntry :: TM [String] getPathEntry = declPath `liftM` getEnv @@ -635,7 +633,7 @@ bindLocals :: [Id] -> TM a -> TM a bindLocals new_ids (TM m) = TM $ \ env st -> case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromUFM` occs, st') + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') where occs = [ nameOccName (idName id) | id <- new_ids ] isBlackListed :: SrcSpan -> TM Bool @@ -655,9 +653,8 @@ allocTickBox boxLabel pos m | isGoodSrcSpan' pos = let c = tickBoxCount st ids = occEnvElts fvs mes = mixEntries st - parentBlock = if declBlock env == noSrcSpan then pos else declBlock env - me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock) - in + me = (pos, map (nameOccName.idName) ids, boxLabel) + in ( L pos (HsTick c ids (L pos e)) , fvs , st {tickBoxCount=c+1,mixEntries=me:mes} @@ -670,8 +667,7 @@ allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id])) allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = sameFileName pos (return Nothing) $ TM $ \ env st -> - let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env - me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock) + let me = (pos, map (nameOccName.idName) ids, boxLabel) c = tickBoxCount st mes = mixEntries st ids = occEnvElts fvs @@ -683,10 +679,9 @@ allocATickBox boxLabel pos fvs = return Nothing allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st -> - let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env - meT = (pos,[],boxLabel True, parentBlock) - meF = (pos,[],boxLabel False, parentBlock) - meE = (pos,[],ExpBox False, parentBlock) + let meT = (pos,[],boxLabel True) + meF = (pos,[],boxLabel False) + meE = (pos,[],ExpBox False) c = tickBoxCount st mes = mixEntries st in @@ -698,7 +693,8 @@ allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st -> , noFVs , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} ) - else ( L pos $ HsTick c [] $ L pos e + else + ( L pos $ HsTick c [] $ L pos e , noFVs , st {tickBoxCount=c+1,mixEntries=meE:mes} ) @@ -741,9 +737,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 \begin{code} -type ParentDecl= SrcSpan -type TickSpan = SrcSpan -type MixEntry_ = (TickSpan, [OccName], BoxLabel, ParentDecl) +type MixEntry_ = (SrcSpan, [OccName], BoxLabel) -- For the hash value, we hash everything: the file name, -- the timestamp of the original source file, the tab stop,