Adding pushing of hpc translation status through hi files.

[ghc-hetmet.git] / compiler / deSugar / Coverage.lhs

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index a9b1a52..f2ad77c 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -28,6 +28,7 @@ import UniqFM
 import Type
 import TyCon
 import FiniteMap
+import PackageConfig 
 
 import Data.Array
 import System.Time (ClockTime(..))
@@ -68,14 +69,14 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do
                    Just file -> file
                    Nothing -> panic "can not find the original file during hpc trans"
 
-  if "boot" `isSuffixOf` orig_file then return (binds, noHpcInfo, emptyModBreaks) else do
+  if "boot" `isSuffixOf` orig_file then return (binds, emptyHpcInfo False, emptyModBreaks) else do
 
   let mod_name = moduleNameString (moduleName mod)
 
   let (binds1,_,st)
                 = unTM (addTickLHsBinds binds) 
                   (TTE
-                      { modName      = mod_name
+                      { fileName    = mkFastString orig_file
                      , declPath     = []
                       , inScope      = emptyVarSet
                      , blackList    = listToFM [ (getSrcSpan (tyConName tyCon),()) 
@@ -91,15 +92,20 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do
   -- write the mix entries for this module
   hashNo <- if opt_Hpc then do
      let hpc_dir = hpcDir dflags
+
+     let hpc_mod_dir = if modulePackageId mod == mainPackageId 
+                      then hpc_dir
+                      else hpc_dir ++ "/" ++ packageIdString (modulePackageId mod)
+
      let tabStop = 1 -- <tab> counts as a normal char in GHC's location ranges.
-     createDirectoryIfMissing True hpc_dir
+     createDirectoryIfMissing True hpc_mod_dir
      modTime <- getModificationTime orig_file
      let entries' = [ (hpcPos, box) 
                     | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
      when (length entries' /= tickBoxCount st) $ do
        panic "the number of .mix entries are inconsistent"
      let hashNo = mixHash orig_file modTime tabStop entries'
-     mixCreate hpc_dir mod_name 
+     mixCreate hpc_mod_dir mod_name 
               $ Mix orig_file modTime (toHash hashNo) tabStop entries'
      return $ hashNo 
    else do
@@ -304,7 +310,10 @@ addTickHsExpr (ExplicitList ty es) =
        liftM2 ExplicitList 
                (return ty)
                (mapM (addTickLHsExpr) es)
-addTickHsExpr (ExplicitPArr     {}) = error "addTickHsExpr: ExplicitPArr"
+addTickHsExpr (ExplicitPArr ty es) =
+       liftM2 ExplicitPArr
+               (return ty)
+               (mapM (addTickLHsExpr) es)
 addTickHsExpr (ExplicitTuple es box) =
        liftM2 ExplicitTuple
                (mapM (addTickLHsExpr) es)
@@ -320,7 +329,6 @@ addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =
                (addTickHsRecordBinds rec_binds)
                (return cons) (return tys1) (return tys2)
 
-addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
 addTickHsExpr (ExprWithTySigOut e ty) =
        liftM2 ExprWithTySigOut
                (addTickLHsExprNever e) -- No need to tick the inner expression
@@ -334,9 +342,18 @@ addTickHsExpr (HsTickPragma (file,(l1,c1),(l2,c2)) (L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) pos $
                 addTickHsExpr e0
     return $ unLoc e2
-addTickHsExpr (PArrSeq  {}) = error "addTickHsExpr: PArrSeq"
-addTickHsExpr (HsSCC    {}) = error "addTickHsExpr: HsSCC"
-addTickHsExpr (HsCoreAnn   {}) = error "addTickHsExpr: HsCoreAnn"
+addTickHsExpr (PArrSeq  ty arith_seq) =
+       liftM2 PArrSeq  
+               (return ty)
+               (addTickArithSeqInfo arith_seq)
+addTickHsExpr (HsSCC nm e) =
+        liftM2 HsSCC 
+                (return nm)
+                (addTickLHsExpr e)
+addTickHsExpr (HsCoreAnn nm e) = 
+        liftM2 HsCoreAnn 
+                (return nm)
+                (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {}) = return e
 addTickHsExpr e@(HsBracketOut  {}) = return e
 addTickHsExpr e@(HsSpliceE  {}) = return e
@@ -363,12 +380,13 @@ addTickHsExpr (HsArrForm e fix cmdtop) =
 
 addTickHsExpr e@(HsType ty) = return e
 
--- Should never happen in expression content.
-addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
-addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
-addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
-addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
-addTickHsExpr (HsTick _ _ _) = error "addTickhsExpr: HsTick _ _"
+-- Others dhould never happen in expression content.
+addTickHsExpr e@(ExprWithTySig {}) = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(EAsPat _ _)       = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(ELazyPat _)       = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(EWildPat)         = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(HsBinTick _ _ _)  = pprPanic "addTickHsExpr" (ppr e)
+addTickHsExpr e@(HsTick _ _ _)     = pprPanic "addTickHsExpr" (ppr e)
 
 addTickMatchGroup (MatchGroup matches ty) = do
   let isOneOfMany = matchesOneOfMany matches
@@ -531,7 +549,7 @@ data TickTransState = TT { tickBoxCount:: Int
                          , mixEntries  :: [MixEntry_]
                          }                        
 
-data TickTransEnv = TTE { modName      :: String
+data TickTransEnv = TTE { fileName      :: FastString
                        , declPath     :: [String]
                         , inScope      :: VarSet
                        , blackList   :: FiniteMap SrcSpan ()
@@ -597,6 +615,17 @@ addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
 getPathEntry :: TM [String]
 getPathEntry = declPath `liftM` getEnv
 
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+sameFileName :: SrcSpan -> TM a -> TM a -> TM a
+sameFileName pos out_of_scope in_scope = do
+  file_name <- getFileName
+  case optSrcSpanFileName pos of 
+    Just file_name2 
+      | file_name == file_name2 -> in_scope
+    _ -> out_of_scope
+
 bindLocals :: [Id] -> TM a -> TM a
 bindLocals new_ids (TM m)
   = TM $ \ env st -> 
@@ -613,7 +642,9 @@ isBlackListed pos = TM $ \ env 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)
-allocTickBox boxLabel pos m | isGoodSrcSpan' pos = do
+allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 
+  sameFileName pos 
+    (do e <- m; return (L pos e)) $ do
   (fvs, e) <- getFreeVars m
   TM $ \ env st ->
     let c = tickBoxCount st
@@ -630,7 +661,9 @@ allocTickBox boxLabel pos m = do e <- m; return (L pos e)
 -- the tick application inherits the source position of its
 -- expression argument to support nested box allocations 
 allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id]))
-allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = TM $ \ env st ->
+allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = 
+  sameFileName pos 
+    (return Nothing) $ TM $ \ env st ->
   let me = (pos, map (nameOccName.idName) ids, boxLabel)
       c = tickBoxCount st
       mes = mixEntries st