I ran across this bug and took the time to fix it, closing
a long time due TODO in InteractiveEval.hs
Instead of looking around to find the enclosing declaration
of a tick, this patch makes use of the information already collected during the
coverage desugaring phase
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationTime orig_file2
let entries' = [ (hpcPos, box)
createDirectoryIfMissing True hpc_mod_dir
modTime <- getModificationTime orig_file2
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_file2 modTime tabStop entries'
when (length entries' /= tickBoxCount st) $ do
panic "the number of .mix entries are inconsistent"
let hashNo = mixHash orig_file2 modTime tabStop entries'
breakArray <- newBreakArray $ length entries
let locsTicks = listArray (0,tickBoxCount st-1)
breakArray <- newBreakArray $ length entries
let locsTicks = listArray (0,tickBoxCount st-1)
- [ span | (span,_,_) <- entries ]
+ [ span | (span,_,_,_) <- entries ]
varsTicks = listArray (0,tickBoxCount st-1)
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 = emptyModBreaks
{ modBreaks_flags = breakArray
, modBreaks_locs = locsTicks
, modBreaks_vars = varsTicks
+ , modBreaks_decls = declsTicks
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
}
doIfSet_dyn dflags Opt_D_dump_hpc $ do
let c = tickBoxCount st
ids = occEnvElts fvs
mes = mixEntries st
let c = tickBoxCount st
ids = occEnvElts fvs
mes = mixEntries st
- me = (pos, map (nameOccName.idName) ids, boxLabel)
+ me = (pos, declPath _env, map (nameOccName.idName) ids, boxLabel)
in
( L pos (HsTick c ids (L pos e))
, fvs
in
( L pos (HsTick c ids (L pos e))
, fvs
allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
sameFileName pos
(return Nothing) $ TM $ \ _env st ->
allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos =
sameFileName pos
(return Nothing) $ TM $ \ _env st ->
- let me = (pos, map (nameOccName.idName) ids, boxLabel)
+ let me = (pos, declPath _env, map (nameOccName.idName) ids, boxLabel)
c = tickBoxCount st
mes = mixEntries st
ids = occEnvElts fvs
c = tickBoxCount st
mes = mixEntries st
ids = occEnvElts fvs
do
e <- m
TM $ \ _env st ->
do
e <- m
TM $ \ _env st ->
- let meT = (pos,[],boxLabel True)
- meF = (pos,[],boxLabel False)
- meE = (pos,[],ExpBox False)
+ let meT = (pos,declPath _env, [],boxLabel True)
+ meF = (pos,declPath _env, [],boxLabel False)
+ meE = (pos,declPath _env, [],ExpBox False)
c = tickBoxCount st
mes = mixEntries st
in
c = tickBoxCount st
mes = mixEntries st
in
-type MixEntry_ = (SrcSpan, [OccName], BoxLabel)
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
-- For the hash value, we hash everything: the file name,
-- the timestamp of the original source file, the tab stop,
-- For the hash value, we hash everything: the file name,
-- the timestamp of the original source file, the tab stop,
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
- History(historyBreakInfo, historyEnclosingDecl),
+ History(historyBreakInfo, historyEnclosingDecls),
GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
GHC.getHistorySpan, getHistoryModule,
getResumeContext,
abandon, abandonAll,
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
-- ^ An array giving the source span of each breakpoint.
, modBreaks_vars :: !(Array BreakIndex [OccName])
-- ^ An array giving the names of the free variables at each breakpoint.
+ , modBreaks_decls :: !(Array BreakIndex [String])
+ -- ^ An array giving the names of the declarations enclosing each breakpoint.
}
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
{ modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-- Todo: can we avoid this?
}
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
{ modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-- Todo: can we avoid this?
- , modBreaks_locs = array (0,-1) []
- , modBreaks_vars = array (0,-1) []
+ , modBreaks_locs = array (0,-1) []
+ , modBreaks_vars = array (0,-1) []
+ , modBreaks_decls = array (0,-1) []
import UniqFM
import Maybes
import ErrUtils
import UniqFM
import Maybes
import ErrUtils
import SrcLoc
import BreakArray
import RtClosureInspect
import SrcLoc
import BreakArray
import RtClosureInspect
import Data.Array
import Exception
import Control.Concurrent
import Data.Array
import Exception
import Control.Concurrent
-import Data.List (sortBy)
-- import Foreign.StablePtr
import System.IO
import System.IO.Unsafe
-- import Foreign.StablePtr
import System.IO
import System.IO.Unsafe
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
= History {
historyApStack :: HValue,
historyBreakInfo :: BreakInfo,
- historyEnclosingDecl :: Id
- -- ^^ A cache of the enclosing top level declaration, for convenience
+ historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint
}
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
}
mkHistory :: HscEnv -> HValue -> BreakInfo -> History
mkHistory hsc_env hval bi = let
- h = History hval bi decl
- decl = findEnclosingDecl hsc_env (getHistoryModule h)
- (getHistorySpan hsc_env h)
- in h
+ decls = findEnclosingDecl hsc_env bi
+ in History hval bi decls
+
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
getHistoryModule :: History -> Module
getHistoryModule = breakInfo_module . historyBreakInfo
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
- | Just linkable <- hm_linkable hmi,
+ | Just linkable <- hm_linkable hmi,
[BCOs _ modBreaks] <- linkableUnlinked linkable
= modBreaks
| otherwise
[BCOs _ modBreaks] <- linkableUnlinked linkable
= modBreaks
| otherwise
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
-- ToDo: a better way to do this would be to keep hold of the decl_path computed
-- by the coverage pass, which gives the list of lexically-enclosing bindings
-- for each tick.
-findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id
-findEnclosingDecl hsc_env mod span =
- case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of
- Nothing -> panic "findEnclosingDecl"
- Just hmi -> let
- globals = typeEnvIds (md_types (hm_details hmi))
- Just decl =
- find (\id -> let n = idName id in
- nameSrcSpan n < span && isExternalName n)
- (reverse$ sortBy (compare `on` (nameSrcSpan.idName))
- globals)
- in decl
+findEnclosingDecl :: HscEnv -> BreakInfo -> [String]
+findEnclosingDecl hsc_env inf =
+ let hmi = expectJust "findEnclosingDecl" $
+ lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf)
+ mb = getModBreaks hmi
+ in modBreaks_decls mb ! breakInfo_number inf
+
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
_ -> do
spans <- mapM GHC.getHistorySpan took
let nums = map (printf "-%-3d:") [(1::Int)..]
_ -> do
spans <- mapM GHC.getHistorySpan took
let nums = map (printf "-%-3d:") [(1::Int)..]
- names = map GHC.historyEnclosingDecl took
+ names = map GHC.historyEnclosingDecls took
printForUser (vcat(zipWith3
(\x y z -> x <+> y <+> z)
(map text nums)
printForUser (vcat(zipWith3
(\x y z -> x <+> y <+> z)
(map text nums)
- (map (bold . ppr) names)
+ (map (bold . hcat . punctuate colon . map text) names)
(map (parens . ppr) spans)))
liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
(map (parens . ppr) spans)))
liftIO $ putStrLn $ if null rest then "<end of history>" else "..."