Commit 6ebfe518 authored by andy@galois.com's avatar andy@galois.com
Browse files

Using blacklist of places not to cover, rather than reverse-engineer deriving.

parent 7a77f1b7
......@@ -27,6 +27,7 @@ import StaticFlags
import UniqFM
import Type
import TyCon
import FiniteMap
import Data.Array
import System.Time (ClockTime(..))
......@@ -54,10 +55,11 @@ 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 +75,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
{ modName = mod_name
, declPath = []
, inScope = emptyVarSet
, blackList = listToFM [ (getSrcSpan (tyConName tyCon),())
| tyCon <- tyCons ]
})
(TT
{ tickBoxCount = 0
......@@ -127,8 +131,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 +143,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 +185,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.
......@@ -541,6 +529,7 @@ data TickTransState = TT { tickBoxCount:: Int
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
, inScope :: VarSet
, blackList :: FiniteMap SrcSpan ()
}
-- deriving Show
......@@ -610,6 +599,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)
......
......@@ -90,7 +90,7 @@ deSugar hsc_env
HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
_ -> do (binds_cvr,ds_hpc_info, modBreaks)
<- if opt_Hpc || target == HscInterpreted
then addCoverageTicksToBinds dflags mod mod_loc binds
then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
else return (binds, noHpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds_cvr
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment