import BreakArray
import Data.HashTable ( hashString )
+
\end{code}
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 = []
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'
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
(fvs, mg@(MatchGroup matches' ty)) <-
getFreeVars $
- addPathEntry name $
+ addPathEntry name pos $
addTickMatchGroup (fun_matches funBind)
blackListed <- isBlackListed pos
-- 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
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]
, 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 ->
-- 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}
-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,