From 6ebfe518116d1c97a9d46013271f359decea2d15 Mon Sep 17 00:00:00 2001
From: "andy@galois.com" <unknown>
Date: Sat, 9 Jun 2007 00:00:21 +0000
Subject: [PATCH] Using blacklist of places not to cover, rather than
 reverse-engineer deriving.

---
 compiler/deSugar/Coverage.lhs |   37 ++++++++++++++++---------------------
 compiler/deSugar/Desugar.lhs  |    2 +-
 2 files changed, 17 insertions(+), 22 deletions(-)

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index f2abd30..2bbf187 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -27,6 +27,7 @@ import StaticFlags
 import UniqFM
 import Type
 import TyCon
+import FiniteMap
 
 import Data.Array
 import System.Time (ClockTime(..))
@@ -54,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
@@ -73,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
@@ -127,8 +131,6 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind bind | isDerivedLHsBind bind = do
-  return bind
 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'
@@ -141,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 
@@ -180,23 +185,6 @@ addTickLHsBind (VarBind var_id var_rhs) = do
 -}
 addTickLHsBind other = return other
 
--- This attempts to locate derived code, so as to not add ticks
--- to compiler generated code. An alternative is to tie *all* the
--- method functions to the deriving class name in the deriving list.
-
--- This fuction works because we use the location of the datatype
--- we are building the instance for as the location of derived code.
-
-isDerivedLHsBind :: LHsBind Id -> Bool
-isDerivedLHsBind (L pos t@(AbsBinds _ _ [(_,the_id,_,_)] _)) = 
-  case splitTyConApp_maybe (varType the_id) of
-    Just (tyCon,[ty]) | isClassTyCon tyCon ->
-	   case splitTyConApp_maybe ty of
-	     Just (tyCon',_) -> getSrcSpan (tyConName tyCon') == getSrcSpan the_id
-	     _ -> False
-    _ -> False
-isDerivedLHsBind _ = False
-
 -- 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.
@@ -541,6 +529,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { modName      :: String
 			, declPath     :: [String]
                         , inScope      :: VarSet
+			, blackList   :: FiniteMap SrcSpan ()
 			}
 
 --	deriving Show
@@ -610,6 +599,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)
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 731d6ff..cb861ae 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -90,7 +90,7 @@ deSugar hsc_env
 	             HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, emptyModBreaks))
                      _        -> do (binds_cvr,ds_hpc_info, modBreaks) 
 					      <- if opt_Hpc || target == HscInterpreted
-                                                 then addCoverageTicksToBinds dflags mod mod_loc binds
+                                                 then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
                                                  else return (binds, noHpcInfo, emptyModBreaks)
                                     initDs hsc_env mod rdr_env type_env $ do
 		                        { core_prs <- dsTopLHsBinds auto_scc binds_cvr
-- 
1.7.10.4