projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add data type information to VectInfo
[ghc-hetmet.git]
/
compiler
/
deSugar
/
Coverage.lhs
diff --git
a/compiler/deSugar/Coverage.lhs
b/compiler/deSugar/Coverage.lhs
index
530e7d2
..
f46d9cd
100644
(file)
--- a/
compiler/deSugar/Coverage.lhs
+++ b/
compiler/deSugar/Coverage.lhs
@@
-70,11
+70,11
@@
addCoverageTicksToBinds dflags mod mod_loc binds = do
(TTE
{ modName = mod_name
, declPath = []
(TTE
{ modName = mod_name
, declPath = []
+ , inScope = emptyVarSet
})
(TT
{ tickBoxCount = 0
, mixEntries = []
})
(TT
{ tickBoxCount = 0
, mixEntries = []
- , inScope = emptyVarSet
})
let entries = reverse $ mixEntries st
})
let entries = reverse $ mixEntries st
@@
-177,10
+177,13
@@
addTickLHsBind (VarBind var_id var_rhs) = do
-}
addTickLHsBind other = return other
-}
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 :: 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
addTickLHsExprNeverOrAlways :: LHsExpr Id -> TM (LHsExpr Id)
addTickLHsExprNeverOrAlways e
@@
-273,10
+276,10
@@
addTickHsExpr (HsIf e1 e2 e3) =
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
+ bindLocals (map unLoc $ collectLocalBinders binds) $
liftM2 HsLet
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)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
@@
-294,17
+297,17
@@
addTickHsExpr (ExplicitTuple es box) =
liftM2 ExplicitTuple
(mapM (addTickLHsExpr) es)
(return box)
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)
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)
(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
addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
addTickHsExpr (ExprWithTySigOut e ty) =
liftM2 ExprWithTySigOut
@@
-513,11
+516,11
@@
addTickArithSeqInfo (FromThenTo e1 e2 e3) =
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry]
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
, mixEntries :: [MixEntry]
- , inScope :: VarSet -- move the TickTransEnv
}
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
}
data TickTransEnv = TTE { modName :: String
, declPath :: [String]
+ , inScope :: VarSet
}
-- deriving Show
}
-- deriving Show
@@
-550,17
+553,12
@@
instance Monad TM where
(r2,fv2,st2) ->
(r2, fv1 `plusOccEnv` fv2, st2)
(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)
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)
getEnv :: TM TickTransEnv
getEnv = TM $ \ env st -> (env, noFVs, st)
@@
-575,7
+573,7
@@
getFreeVars (TM m)
freeVar :: Id -> TM ()
freeVar id = TM $ \ env 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)
then ((), unitOccEnv (nameOccName (idName id)) id, st)
else ((), noFVs, st)
@@
-588,7
+586,7
@@
getPathEntry = declPath `liftM` getEnv
bindLocals :: [Id] -> TM a -> TM a
bindLocals new_ids (TM m)
= TM $ \ env 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 ]
(r, fv, st') -> (r, fv `delListFromUFM` occs, st')
where occs = [ nameOccName (idName id) | id <- new_ids ]