X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=b0e92bb20ea0ea72ab0e26038cc68cb230bc1675;hp=f32ce9360968191f7f062f18bf60617fe70ab9df;hb=ba05282d3915e7051b3f016366b971a8506b0093;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index f32ce93..b0e92bb 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -23,7 +23,6 @@ import FastString
 import HscTypes	
 import StaticFlags
 import TyCon
-import FiniteMap
 import MonadUtils
 import Maybes
 
@@ -35,6 +34,8 @@ import Trace.Hpc.Util
 
 import BreakArray 
 import Data.HashTable   ( hashString )
+import Data.Map (Map)
+import qualified Data.Map as Map
 \end{code}
 
 
@@ -76,8 +77,8 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
 		       { fileName    = mkFastString orig_file2
 		      , declPath     = []
                       , inScope      = emptyVarSet
-		      , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
-		      		       		| tyCon <- tyCons ]
+		      , blackList    = Map.fromList [ (getSrcSpan (tyConName tyCon),()) 
+		                                    | tyCon <- tyCons ]
 		       })
 		   (TT 
 		      { tickBoxCount = 0
@@ -98,7 +99,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
      createDirectoryIfMissing True hpc_mod_dir
      modTime <- getModificationTime orig_file2
      let entries' = [ (hpcPos, box) 
-                    | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+                    | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
      when (length entries' /= tickBoxCount st) $ do
        panic "the number of .mix entries are inconsistent"
      let hashNo = mixHash orig_file2 modTime tabStop entries'
@@ -112,13 +113,16 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
   breakArray <- newBreakArray $ length entries
 
   let locsTicks = listArray (0,tickBoxCount st-1) 
-                     [ span | (span,_,_) <- entries ]
+                     [ span | (span,_,_,_) <- entries ]
       varsTicks = listArray (0,tickBoxCount st-1) 
-                     [ vars | (_,vars,_) <- entries ]
+                     [ vars | (_,_,vars,_) <- entries ]
+      declsTicks= listArray (0,tickBoxCount st-1) 
+                     [ decls | (_,decls,_,_) <- entries ]
       modBreaks = emptyModBreaks 
                   { modBreaks_flags = breakArray 
                   , modBreaks_locs  = locsTicks 
                   , modBreaks_vars  = varsTicks
+                  , modBreaks_decls = declsTicks
                   } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
@@ -285,8 +289,8 @@ addTickHsExpr (HsCase e mgs) =
 	liftM2 HsCase
 		(addTickLHsExpr e) 
 		(addTickMatchGroup mgs)
-addTickHsExpr (HsIf	 e1 e2 e3) = 
-	liftM3 HsIf
+addTickHsExpr (HsIf cnd e1 e2 e3) = 
+	liftM3 (HsIf cnd)
 		(addBinTickLHsExpr (BinBox CondBinBox) e1)
 		(addTickLHsExprOptAlt True e2)
 		(addTickLHsExprOptAlt True e3)
@@ -461,10 +465,8 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; dicts' <- addTickEvBinds (recS_dicts stmt)
        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
-                      , recS_mfix_fn = mfix', recS_bind_fn = bind'
-                      , recS_dicts = dicts' }) }
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
 
 addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
@@ -535,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
-addTickEvBinds :: TcEvBinds -> TM TcEvBinds
-addTickEvBinds x = return x   -- No coverage testing for dictionary binding
-
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd) 
   = do	{ fields' <- mapM process fields
@@ -574,7 +573,7 @@ data TickTransState = TT { tickBoxCount:: Int
 data TickTransEnv = TTE { fileName      :: FastString
 			, declPath     :: [String]
                         , inScope      :: VarSet
-			, blackList   :: FiniteMap SrcSpan ()
+			, blackList   :: Map SrcSpan ()
 			}
 
 --	deriving Show
@@ -658,7 +657,7 @@ bindLocals new_ids (TM m)
 
 isBlackListed :: SrcSpan -> TM Bool
 isBlackListed pos = TM $ \ env st -> 
-	      case lookupFM (blackList env) pos of
+	      case Map.lookup pos (blackList env) of
 	        Nothing -> (False,noFVs,st)
 		Just () -> (True,noFVs,st)
 
@@ -669,11 +668,11 @@ allocTickBox boxLabel pos m | isGoodSrcSpan' pos =
   sameFileName pos 
     (do e <- m; return (L pos e)) $ do
   (fvs, e) <- getFreeVars m
-  TM $ \ _env st ->
+  TM $ \ env st ->
     let c = tickBoxCount st
         ids = occEnvElts fvs
         mes = mixEntries st
-        me = (pos, map (nameOccName.idName) ids, boxLabel)
+        me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel)
     in
     ( L pos (HsTick c ids (L pos e))
     , fvs
@@ -686,8 +685,11 @@ allocTickBox _boxLabel pos m = do e <- m; return (L pos e)
 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
 allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
   sameFileName pos 
-    (return Nothing) $ TM $ \ _env st ->
-  let me = (pos, map (nameOccName.idName) ids, boxLabel)
+    (return Nothing) $ TM $ \ env st ->
+  let mydecl_path
+        | null (declPath env), TopLevelBox x <- boxLabel = x
+        | otherwise = declPath env
+      me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel)
       c = tickBoxCount st
       mes = mixEntries st
       ids = occEnvElts fvs
@@ -704,10 +706,10 @@ allocBinTickBox boxLabel pos m
  | isGoodSrcSpan' pos =
  do
  e <- m
- TM $ \ _env st ->
-  let meT = (pos,[],boxLabel True)
-      meF = (pos,[],boxLabel False)
-      meE = (pos,[],ExpBox False)
+ TM $ \ env st ->
+  let meT = (pos,declPath env, [],boxLabel True)
+      meF = (pos,declPath env, [],boxLabel False)
+      meE = (pos,declPath env, [],ExpBox False)
       c = tickBoxCount st
       mes = mixEntries st
   in 
@@ -756,7 +758,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
 
 
 \begin{code}
-type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
 
 -- For the hash value, we hash everything: the file name, 
 --  the timestamp of the original source file, the tab stop,