X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=3a3b7458f18a794ee0c5e9c9638e8ae149594443;hb=596cacfe4e9463d1fd66c3292bef7432cfb1b17a;hp=501ee817db02b195622fa443ccf3444e17d624d8;hpb=a171dac28baada2036577e7b0b4d7cc1c6836952;p=ghc-hetmet.git diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 501ee81..3a3b745 100644 --- 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(..)) @@ -38,13 +39,12 @@ import Compat.Directory ( createDirectoryIfMissing ) import System.Directory ( createDirectoryIfMissing ) #endif -#if GHCI import Trace.Hpc.Mix import Trace.Hpc.Util -#endif import BreakArray import Data.HashTable ( hashString ) + \end{code} @@ -63,7 +63,6 @@ addCoverageTicksToBinds -> LHsBinds Id -> IO (LHsBinds Id, HpcInfo, ModBreaks) -#if GHCI addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do let orig_file = @@ -71,19 +70,19 @@ 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),()) | tyCon <- tyCons ] - }) + , declBlock = noSrcSpan }) (TT { tickBoxCount = 0 , mixEntries = [] @@ -94,15 +93,21 @@ 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 -- 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] ] + | (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 (Mix orig_file modTime (toHash hashNo) tabStop entries') + mixCreate hpc_mod_dir mod_name + $ Mix orig_file modTime (toHash hashNo) tabStop entries' return $ hashNo else do return $ 0 @@ -111,13 +116,16 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 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 @@ -146,7 +154,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do (fvs, mg@(MatchGroup matches' ty)) <- getFreeVars $ - addPathEntry name $ + addPathEntry name pos $ addTickMatchGroup (fun_matches funBind) blackListed <- isBlackListed pos @@ -175,7 +183,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_rhs = rhs }))) = do let name = "(...)" - rhs' <- addPathEntry name $ addTickGRHSs False rhs + rhs' <- addPathEntry name pos $ addTickGRHSs False rhs {- decl_path <- getPathEntry tick_me <- allocTickBox (if null decl_path @@ -306,7 +314,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) @@ -322,7 +333,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 @@ -336,9 +346,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 @@ -365,12 +384,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 @@ -393,10 +413,10 @@ addTickGRHSs isOneOfMany (GRHSs guarded local_binds) = do binders = map unLoc (collectLocalBinders local_binds) addTickGRHS :: Bool -> GRHS Id -> TM (GRHS Id) -addTickGRHS isOneOfMany (GRHS stmts expr) = do +addTickGRHS isOneOfMany (GRHS stmts expr@(L pos _)) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts (if opt_Hpc then addTickLHsExprOptAlt isOneOfMany expr - else addTickLHsExprAlways expr) + else addPathEntry "" pos $ addTickLHsExprAlways expr) return $ GRHS stmts' expr' addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id] @@ -533,10 +553,11 @@ data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] } -data TickTransEnv = TTE { modName :: String +data TickTransEnv = TTE { fileName :: FastString , declPath :: [String] , inScope :: VarSet , blackList :: FiniteMap SrcSpan () + , declBlock :: SrcSpan } -- deriving Show @@ -593,12 +614,23 @@ freeVar id = TM $ \ env st -> then ((), unitOccEnv (nameOccName (idName id)) id, st) else ((), noFVs, st) -addPathEntry :: String -> TM a -> TM a -addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) +addPathEntry :: String -> SrcSpan -> TM a -> TM a +addPathEntry nm src = withEnv (\ env -> env { declPath = declPath env ++ [nm], declBlock = src }) 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 -> @@ -615,14 +647,17 @@ 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 ids = occEnvElts fvs mes = mixEntries st - me = (pos, map (nameOccName.idName) ids, boxLabel) - in + parentBlock = if declBlock env == noSrcSpan then pos else declBlock env + me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock) + in ( L pos (HsTick c ids (L pos e)) , fvs , st {tickBoxCount=c+1,mixEntries=me:mes} @@ -632,8 +667,11 @@ 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 -> - let me = (pos, map (nameOccName.idName) ids, boxLabel) +allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = + sameFileName pos + (return Nothing) $ TM $ \ env st -> + let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env + me = (pos, map (nameOccName.idName) ids, boxLabel, parentBlock) c = tickBoxCount st mes = mixEntries st ids = occEnvElts fvs @@ -645,9 +683,10 @@ allocATickBox boxLabel pos fvs = return Nothing allocBinTickBox :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st -> - let meT = (pos,[],boxLabel True) - meF = (pos,[],boxLabel False) - meE = (pos,[],ExpBox False) + let parentBlock = if declBlock env == noSrcSpan then pos else declBlock env + meT = (pos,[],boxLabel True, parentBlock) + meF = (pos,[],boxLabel False, parentBlock) + meE = (pos,[],ExpBox False, parentBlock) c = tickBoxCount st mes = mixEntries st in @@ -659,8 +698,7 @@ allocBinTickBox boxLabel (L pos e) | isGoodSrcSpan' pos = TM $ \ env st -> , noFVs , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes} ) - else - ( L pos $ HsTick c [] $ L pos e + else ( L pos $ HsTick c [] $ L pos e , noFVs , st {tickBoxCount=c+1,mixEntries=meE:mes} ) @@ -703,7 +741,9 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 \begin{code} -type MixEntry_ = (SrcSpan, [OccName], BoxLabel) +type ParentDecl= SrcSpan +type TickSpan = SrcSpan +type MixEntry_ = (TickSpan, [OccName], BoxLabel, ParentDecl) -- For the hash value, we hash everything: the file name, -- the timestamp of the original source file, the tab stop, @@ -715,11 +755,3 @@ mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} - - -\begin{code} -#else -addCoverageTicksToBinds dflags mod mod_loc tyCons binds = - return (binds, noHpcInfo, emptyModBreaks) -#endif -\end{code} \ No newline at end of file