X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=116d3bf0538b79fefb8461780c1a97f97cd1fa54;hp=a011df6913e42b876b874c70d67072d3ea11bea2;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hpb=e546aeee4ad0e2058250440e9a199665f84b5959

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index a011df6..116d3bf 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -25,6 +25,9 @@ import FastString
 import HscTypes	
 import StaticFlags
 import UniqFM
+import Type
+import TyCon
+import FiniteMap
 
 import Data.Array
 import System.Time (ClockTime(..))
@@ -52,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
@@ -71,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
@@ -125,10 +131,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds 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'
-
 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)
 
+  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 
@@ -177,10 +185,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 +284,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)
@@ -484,12 +495,13 @@ addTickDictBinds :: DictBinds Id -> TM (DictBinds 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) =
@@ -518,6 +530,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { modName      :: String
 			, declPath     :: [String]
                         , inScope      :: VarSet
+			, blackList   :: FiniteMap SrcSpan ()
 			}
 
 --	deriving Show
@@ -550,8 +563,8 @@ 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)
@@ -587,6 +600,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)