X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=8d9090073c4a3c2941311087771f44eee487c2b7;hb=53ebe8abd4f307200f8f513e0ebb11f4d0cd14d9;hp=f2abd30338c9e9db0886bdbff3e22f765c453ffc;hpb=7a77f1b7a336d07749145d25763ccb587de17df1;p=ghc-hetmet.git diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index f2abd30..8d90900 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -27,10 +27,11 @@ import StaticFlags import UniqFM import Type import TyCon +import FiniteMap +import PackageConfig import Data.Array import System.Time (ClockTime(..)) -import System.Directory (getModificationTime) import System.IO (FilePath) #if __GLASGOW_HASKELL__ < 603 import Compat.Directory ( createDirectoryIfMissing ) @@ -38,6 +39,9 @@ import Compat.Directory ( createDirectoryIfMissing ) import System.Directory ( createDirectoryIfMissing ) #endif +import Trace.Hpc.Mix +import Trace.Hpc.Util + import BreakArray import Data.HashTable ( hashString ) \end{code} @@ -54,10 +58,12 @@ addCoverageTicksToBinds :: DynFlags -> Module -> ModLocation -- of the current module + -> [TyCon] -- type constructor in this module -> LHsBinds Id -> IO (LHsBinds Id, HpcInfo, ModBreaks) -addCoverageTicksToBinds dflags mod mod_loc binds = do +addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do + let orig_file = case ml_hs_file mod_loc of Just file -> file @@ -73,6 +79,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do { modName = mod_name , declPath = [] , inScope = emptyVarSet + , blackList = listToFM [ (getSrcSpan (tyConName tyCon),()) + | tyCon <- tyCons ] }) (TT { tickBoxCount = 0 @@ -84,15 +92,21 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do -- write the mix entries for this module hashNo <- if opt_Hpc then do let hpc_dir = hpcDir dflags + + let hpc_mod_dir = if modulePackageId mod == mainPackageId + then hpc_dir + else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod) + let tabStop = 1 -- counts as a normal char in GHC's location ranges. - createDirectoryIfMissing True hpc_dir - modTime <- getModificationTime' orig_file + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationTime orig_file let entries' = [ (hpcPos, box) | (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' - mixCreate hpc_dir mod_name (Mix orig_file modTime hashNo tabStop entries') + mixCreate hpc_mod_dir mod_name + $ Mix orig_file modTime (toHash hashNo) tabStop entries' return $ hashNo else do return $ 0 @@ -127,8 +141,6 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) addTickLHsBinds binds = mapBagM addTickLHsBind binds addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) -addTickLHsBind bind | isDerivedLHsBind bind = do - return bind addTickLHsBind (L pos t@(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' @@ -141,8 +153,11 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do addPathEntry name $ addTickMatchGroup (fun_matches funBind) + blackListed <- isBlackListed pos + -- Todo: we don't want redundant ticks on simple pattern bindings - if not opt_Hpc && isSimplePatBind funBind + -- We don't want to generate code for blacklisted positions + if blackListed || (not opt_Hpc && isSimplePatBind funBind) then return $ L pos $ funBind { fun_matches = MatchGroup matches' ty , fun_tick = Nothing @@ -180,23 +195,6 @@ addTickLHsBind (VarBind var_id var_rhs) = do -} addTickLHsBind other = return other --- This attempts to locate derived code, so as to not add ticks --- to compiler generated code. An alternative is to tie *all* the --- method functions to the deriving class name in the deriving list. - --- This fuction works because we use the location of the datatype --- we are building the instance for as the location of derived code. - -isDerivedLHsBind :: LHsBind Id -> Bool -isDerivedLHsBind (L pos t@(AbsBinds _ _ [(_,the_id,_,_)] _)) = - case splitTyConApp_maybe (varType the_id) of - Just (tyCon,[ty]) | isClassTyCon tyCon -> - case splitTyConApp_maybe ty of - Just (tyCon',_) -> getSrcSpan (tyConName tyCon') == getSrcSpan the_id - _ -> False - _ -> False -isDerivedLHsBind _ = False - -- 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 -- a tick here because there will definititely be a tick on the body anyway. @@ -507,12 +505,13 @@ addTickDictBinds :: DictBinds Id -> TM (DictBinds Id) addTickDictBinds x = addTickLHsBinds x addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) -addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs) - where - process (ids,expr) = - liftM2 (,) - (return ids) - (addTickLHsExpr expr) +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM process fields + ; return (HsRecFields fields' dd) } + where + process (HsRecField ids expr doc) + = do { expr' <- addTickLHsExpr expr + ; return (HsRecField ids expr' doc) } addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) addTickArithSeqInfo (From e1) = @@ -535,12 +534,13 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) = \begin{code} data TickTransState = TT { tickBoxCount:: Int - , mixEntries :: [MixEntry] + , mixEntries :: [MixEntry_] } data TickTransEnv = TTE { modName :: String , declPath :: [String] , inScope :: VarSet + , blackList :: FiniteMap SrcSpan () } -- deriving Show @@ -610,6 +610,12 @@ bindLocals new_ids (TM m) (r, fv, st') -> (r, fv `delListFromUFM` occs, st') where occs = [ nameOccName (idName id) | id <- new_ids ] +isBlackListed :: SrcSpan -> TM Bool +isBlackListed pos = TM $ \ env st -> + case lookupFM (blackList env) pos of + Nothing -> (False,noFVs,st) + Just () -> (True,noFVs,st) + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> SrcSpan -> TM (HsExpr Id) -> TM (LHsExpr Id) @@ -701,37 +707,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 \begin{code} --- | 'Mix' is the information about a modules static properties, like --- location of Tix's in a file. --- tab stops are the size of a tab in the provided line:colunm values. --- * In GHC, this is 1 (a tab is just a character) --- * With hpc-tracer, this is 8 (a tab represents several spaces). - -data Mix = Mix - FilePath -- ^location of original file - Integer -- ^time (in seconds) of original file's last update, since 1970. - Int -- ^hash of mix entry + timestamp - Int -- ^tab stop value. - [MixEntry_] -- ^entries - deriving (Show, Read) - --- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before, --- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do, --- because if some other program also defined that instance, we will not be able to compile. - -type MixEntry = (SrcSpan, [OccName], BoxLabel) -type MixEntry_ = (HpcPos, BoxLabel) - -data BoxLabel = ExpBox Bool -- isAlt - | TopLevelBox [String] - | LocalBox [String] - | BinBox CondBox Bool - deriving (Read, Show, Eq, Ord) - -data CondBox = GuardBinBox - | CondBinBox - | QualBinBox - deriving (Read, Show, Eq, Ord) +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, @@ -739,42 +715,7 @@ data CondBox = GuardBinBox -- This hash only has to be hashed at Mix creation time, -- and is for sanity checking only. -mixHash :: FilePath -> Integer -> Int -> [MixEntry_] -> Int +mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) - -mixCreate :: String -> String -> Mix -> IO () -mixCreate dirName modName mix = - writeFile (mixName dirName modName) (show mix) - -mixName :: FilePath -> String -> String -mixName dirName name = dirName ++ "/" ++ name ++ ".mix" - -getModificationTime' :: FilePath -> IO Integer -getModificationTime' file = do - (TOD sec _) <- System.Directory.getModificationTime file - return $ sec - --- a program index records module names and numbers of tick-boxes --- introduced in each module that has been transformed for coverage - -data HpcPos = P !Int !Int !Int !Int deriving (Eq) - -toHpcPos :: (Int,Int,Int,Int) -> HpcPos -toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2 - -instance Show HpcPos where - show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2 - -instance Read HpcPos where - readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)] - where - (before,after) = span (/= ',') pos - (lhs,rhs) = case span (/= '-') before of - (lhs,'-':rhs) -> (lhs,rhs) - (lhs,"") -> (lhs,lhs) - (l1,':':c1) = span (/= ':') lhs - (l2,':':c2) = span (/= ':') rhs - \end{code} -