projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add several new record features
[ghc-hetmet.git]
/
compiler
/
deSugar
/
Coverage.lhs
diff --git
a/compiler/deSugar/Coverage.lhs
b/compiler/deSugar/Coverage.lhs
index
f46d9cd
..
116d3bf
100644
(file)
--- a/
compiler/deSugar/Coverage.lhs
+++ b/
compiler/deSugar/Coverage.lhs
@@
-25,6
+25,9
@@
import FastString
import HscTypes
import StaticFlags
import UniqFM
import HscTypes
import StaticFlags
import UniqFM
+import Type
+import TyCon
+import FiniteMap
import Data.Array
import System.Time (ClockTime(..))
import Data.Array
import System.Time (ClockTime(..))
@@
-52,10
+55,11
@@
addCoverageTicksToBinds
:: DynFlags
-> Module
-> ModLocation -- of the current module
:: DynFlags
-> Module
-> ModLocation -- of the current module
+ -> [TyCon] -- type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
-> 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
let orig_file =
case ml_hs_file mod_loc of
Just file -> file
@@
-71,6
+75,8
@@
addCoverageTicksToBinds dflags mod mod_loc binds = do
{ modName = mod_name
, declPath = []
, inScope = emptyVarSet
{ modName = mod_name
, declPath = []
, inScope = emptyVarSet
+ , blackList = listToFM [ (getSrcSpan (tyConName tyCon),())
+ | tyCon <- tyCons ]
})
(TT
{ tickBoxCount = 0
})
(TT
{ tickBoxCount = 0
@@
-125,10
+131,9
@@
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTickLHsBind binds
addTickLHsBind :: LHsBind Id -> TM (LHsBind 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
+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'
abs_binds' <- addTickLHsBinds abs_binds
return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
-
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
@@
-138,8
+143,11
@@
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
addPathEntry name $
addTickMatchGroup (fun_matches funBind)
addPathEntry name $
addTickMatchGroup (fun_matches funBind)
+ blackListed <- isBlackListed pos
+
-- Todo: we don't want redundant ticks on simple pattern bindings
-- 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
then
return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
, fun_tick = Nothing
@@
-487,12
+495,13
@@
addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
addTickDictBinds x = addTickLHsBinds x
addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds 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) =
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
@@
-521,6
+530,7
@@
data TickTransState = TT { tickBoxCount:: Int
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
, inScope :: VarSet
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
, inScope :: VarSet
+ , blackList :: FiniteMap SrcSpan ()
}
-- deriving Show
}
-- deriving Show
@@
-590,6
+600,12
@@
bindLocals new_ids (TM m)
(r, fv, st') -> (r, fv `delListFromUFM` occs, st')
where occs = [ nameOccName (idName id) | id <- new_ids ]
(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)
-- 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)