X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=f46d9cd23a17a4cfdb5913446f98b1d8a352ab4c;hb=72fbfd1c72d4b3b331e201289ef2ce98d848d879;hp=530e7d2edfd578dd1fca08dee0c5b5881343b33e;hpb=55a5d8d90280a611bafb659bc80778d3927a6bff;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 530e7d2..f46d9cd 100644
--- 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     = []
+                      , inScope      = emptyVarSet
 		       })
 		   (TT 
 		      { tickBoxCount = 0
 		      , mixEntries   = []
-                      , inScope      = emptyVarSet
 		      })
 
   let entries = reverse $ mixEntries st
@@ -177,10 +177,13 @@ addTickLHsBind (VarBind var_id var_rhs) = do
 -}
 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
@@ -273,10 +276,10 @@ addTickHsExpr (HsIf	 e1 e2 e3) =
 		(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)
@@ -294,17 +297,17 @@ addTickHsExpr (ExplicitTuple es 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)
-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
@@ -513,11 +516,11 @@ addTickArithSeqInfo (FromThenTo e1 e2 e3) =
 \begin{code}
 data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry]
-                         , inScope     :: VarSet	-- move the TickTransEnv
                          }                        
 
 data TickTransEnv = TTE { modName      :: String
 			, declPath     :: [String]
+                        , inScope      :: VarSet
 			}
 
 --	deriving Show
@@ -550,17 +553,12 @@ instance Monad TM where
                                        (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)
 
@@ -575,7 +573,7 @@ getFreeVars (TM m)
 
 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)
 
@@ -588,7 +586,7 @@ getPathEntry = declPath `liftM` getEnv
 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 ]