X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FCoverage.lhs;h=3a3b7458f18a794ee0c5e9c9638e8ae149594443;hb=3240dc3b54438e55cdbc7d449aeaaad705bbb653;hp=12c5b4f0aa23a5ab1484e2d942695ebc668932c9;hpb=66cc3339bd3b21a226cee5177bb2b8378c925ea7;p=ghc-hetmet.git diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 12c5b4f..3a3b745 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -44,6 +44,7 @@ import Trace.Hpc.Util import BreakArray import Data.HashTable ( hashString ) + \end{code} @@ -69,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 = [] @@ -101,7 +102,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = do 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' @@ -115,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 @@ -150,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 @@ -179,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 @@ -329,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 @@ -381,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 @@ -409,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] @@ -549,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 @@ -609,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 -> @@ -631,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} @@ -648,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 @@ -661,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 @@ -675,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} ) @@ -719,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,