import HscTypes
import StaticFlags
import UniqFM
+import Type
+import TyCon
+import FiniteMap
+import PackageConfig
import Data.Array
import System.Time (ClockTime(..))
-import System.Directory (getModificationTime)
import System.IO (FilePath)
#if __GLASGOW_HASKELL__ < 603
import Compat.Directory ( createDirectoryIfMissing )
import System.Directory ( createDirectoryIfMissing )
#endif
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+
import BreakArray
import Data.HashTable ( hashString )
+
\end{code}
:: 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
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 = []
-- 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
- modTime <- getModificationTime' orig_file
+ 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 hashNo tabStop entries')
+ mixCreate hpc_mod_dir mod_name
+ $ Mix orig_file modTime (toHash hashNo) tabStop entries'
return $ hashNo
else do
return $ 0
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
addTickLHsBinds binds = mapBagM addTickLHsBind binds
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
+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'
-
addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
let name = getOccString id
decl_path <- getPathEntry
(fvs, mg@(MatchGroup matches' ty)) <-
getFreeVars $
- addPathEntry name $
+ addPathEntry name pos $
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
-- 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
(addTickLHsExprOptAlt True e2)
(addTickLHsExprOptAlt True e3)
addTickHsExpr (HsLet binds e) =
+ bindLocals (map unLoc $ collectLocalBinders binds) $
liftM2 HsLet
- (addTickHsLocalBinds binds) -- to think about: !patterns.
- (bindLocals (map unLoc $ collectLocalBinders binds) $
- addTickLHsExprNeverOrAlways e)
+ (addTickHsLocalBinds binds) -- to think about: !patterns.
+ (addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
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)
(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
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
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
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]
addTickDictBinds x = addTickLHsBinds x
addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
-addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
- where
- process (ids,expr) =
- liftM2 (,)
- (return ids)
- (addTickLHsExpr expr)
+addTickHsRecordBinds (HsRecFields fields dd)
+ = do { fields' <- mapM process fields
+ ; return (HsRecFields fields' dd) }
+ where
+ process (HsRecField ids expr doc)
+ = do { expr' <- addTickLHsExpr expr
+ ; return (HsRecField ids expr' doc) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
\begin{code}
data TickTransState = TT { tickBoxCount:: Int
- , mixEntries :: [MixEntry]
+ , mixEntries :: [MixEntry_]
}
-data TickTransEnv = TTE { modName :: String
+data TickTransEnv = TTE { fileName :: FastString
, declPath :: [String]
, inScope :: VarSet
+ , blackList :: FiniteMap SrcSpan ()
+ , declBlock :: SrcSpan
}
-- deriving Show
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 ->
(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)
-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}
-- 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
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
, 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}
)
\begin{code}
--- | 'Mix' is the information about a modules static properties, like
--- location of Tix's in a file.
--- tab stops are the size of a tab in the provided line:colunm values.
--- * In GHC, this is 1 (a tab is just a character)
--- * With hpc-tracer, this is 8 (a tab represents several spaces).
-
-data Mix = Mix
- FilePath -- ^location of original file
- Integer -- ^time (in seconds) of original file's last update, since 1970.
- Int -- ^hash of mix entry + timestamp
- Int -- ^tab stop value.
- [MixEntry_] -- ^entries
- deriving (Show, Read)
-
--- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
--- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
--- because if some other program also defined that instance, we will not be able to compile.
-
-type MixEntry = (SrcSpan, [OccName], BoxLabel)
-type MixEntry_ = (HpcPos, BoxLabel)
-
-data BoxLabel = ExpBox Bool -- isAlt
- | TopLevelBox [String]
- | LocalBox [String]
- | BinBox CondBox Bool
- deriving (Read, Show, Eq, Ord)
-
-data CondBox = GuardBinBox
- | CondBinBox
- | QualBinBox
- deriving (Read, Show, Eq, Ord)
+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,
-- This hash only has to be hashed at Mix creation time,
-- and is for sanity checking only.
-mixHash :: FilePath -> Integer -> Int -> [MixEntry_] -> Int
+mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int
mixHash file tm tabstop entries = fromIntegral $ hashString
(show $ Mix file tm 0 tabstop entries)
-
-mixCreate :: String -> String -> Mix -> IO ()
-mixCreate dirName modName mix =
- writeFile (mixName dirName modName) (show mix)
-
-mixName :: FilePath -> String -> String
-mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
-
-getModificationTime' :: FilePath -> IO Integer
-getModificationTime' file = do
- (TOD sec _) <- System.Directory.getModificationTime file
- return $ sec
-
--- a program index records module names and numbers of tick-boxes
--- introduced in each module that has been transformed for coverage
-
-data HpcPos = P !Int !Int !Int !Int deriving (Eq)
-
-toHpcPos :: (Int,Int,Int,Int) -> HpcPos
-toHpcPos (l1,c1,l2,c2) = P l1 c1 l2 c2
-
-instance Show HpcPos where
- show (P l1 c1 l2 c2) = show l1 ++ ':' : show c1 ++ '-' : show l2 ++ ':' : show c2
-
-instance Read HpcPos where
- readsPrec _i pos = [(toHpcPos (read l1,read c1,read l2,read c2),after)]
- where
- (before,after) = span (/= ',') pos
- (lhs,rhs) = case span (/= '-') before of
- (lhs,'-':rhs) -> (lhs,rhs)
- (lhs,"") -> (lhs,lhs)
- (l1,':':c1) = span (/= ':') lhs
- (l2,':':c2) = span (/= ':') rhs
-
\end{code}
-
projects / ghc-hetmet.git / blobdiff