import HscTypes
import StaticFlags
import UniqFM
+import Type
+import TyCon
+import FiniteMap
import Data.Array
import System.Time (ClockTime(..))
:: 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
(TTE
{ modName = mod_name
, declPath = []
+ , inScope = emptyVarSet
+ , blackList = listToFM [ (getSrcSpan (tyConName tyCon),())
+ | tyCon <- tyCons ]
})
(TT
{ tickBoxCount = 0
, mixEntries = []
- , inScope = emptyVarSet
})
let entries = reverse $ mixEntries st
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'
-
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
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
-}
addTickLHsBind other = return other
--- add a tick to the expression no matter what it is
+-- 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.
addTickLHsExprAlways :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExprAlways (L pos e0) = do
- allocTickBox (ExpBox False) pos $ addTickHsExpr e0
+addTickLHsExprAlways (L pos e0)
+ | not opt_Hpc, HsLet _ _ <- e0 = addTickLHsExprNever (L pos e0)
+ | otherwise = allocTickBox (ExpBox False) pos $ addTickHsExpr e0
addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrAlways e
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
+ bindLocals (map unLoc $ collectLocalBinders binds) $
liftM2 HsLet
- (addTickHsLocalBinds binds) -- to think about: !patterns.
- (bindLocals (map unLoc $ collectLocalBinders binds) $
- addTickLHsExprNeverOrAlways e)
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
liftM2 ExplicitTuple
(mapM (addTickLHsExpr) es)
(return box)
-addTickHsExpr (RecordCon id ty rec_binds) =
+addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
(return ty)
(addTickHsRecordBinds rec_binds)
-addTickHsExpr (RecordUpd e rec_binds ty1 ty2) =
- liftM4 RecordUpd
+addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
+ liftM5 RecordUpd
(addTickLHsExpr e)
(addTickHsRecordBinds rec_binds)
- (return ty1)
- (return ty2)
+ (return cons) (return tys1) (return tys2)
+
addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
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) =
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry]
- , inScope :: VarSet -- move the TickTransEnv
}
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
+ , inScope :: VarSet
+ , blackList :: FiniteMap SrcSpan ()
}
-- deriving Show
(r2,fv2,st2) ->
(r2, fv1 `plusOccEnv` fv2, st2)
-getState :: TM TickTransState
-getState = TM $ \ env st -> (st, noFVs, st)
+-- getState :: TM TickTransState
+-- getState = TM $ \ env st -> (st, noFVs, st)
setState :: (TickTransState -> TickTransState) -> TM ()
setState f = TM $ \ env st -> ((), noFVs, f st)
-withState :: (TickTransState -> TickTransState) -> TM a -> TM a
-withState f (TM m) = TM $ \ env st ->
- case m env (f st) of
- (a, fvs, st') -> (a, fvs, st')
-
getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)
freeVar :: Id -> TM ()
freeVar id = TM $ \ env st ->
- if id `elemVarSet` inScope st
+ if id `elemVarSet` inScope env
then ((), unitOccEnv (nameOccName (idName id)) id, st)
else ((), noFVs, st)
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ env st ->
- case m env st{ inScope = inScope st `extendVarSetList` new_ids } of
+ case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
(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)
projects / ghc-hetmet.git / blobdiff