From add9b7f13aad3a6ec5fdb4512c79ee9c5d95b3d4 Mon Sep 17 00:00:00 2001 From: "pepeiborra@gmail.com" Date: Mon, 15 Nov 2010 22:36:23 +0000 Subject: [PATCH] Fix bug #3165 (:history throws irrefutable pattern failed) 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 --- compiler/deSugar/Coverage.lhs | 21 ++++++++++++--------- compiler/main/GHC.hs | 2 +- compiler/main/HscTypes.lhs | 7 +++++-- compiler/main/InteractiveEval.hs | 33 ++++++++++++--------------------- ghc/InteractiveUI.hs | 4 ++-- 5 files changed, 32 insertions(+), 35 deletions(-) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index d894523..ea41d98 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -99,7 +99,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = 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' @@ -113,13 +113,16 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds = 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 @@ -674,7 +677,7 @@ allocTickBox boxLabel pos m | isGoodSrcSpan' pos = 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 @@ -688,7 +691,7 @@ allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id])) 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 @@ -706,9 +709,9 @@ allocBinTickBox boxLabel pos m 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 @@ -757,7 +760,7 @@ matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 \begin{code} -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, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index e1bc5de..6f42aed 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -96,7 +96,7 @@ module GHC ( resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo, historyEnclosingDecl), + History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 33b4448..8a17a40 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1850,13 +1850,16 @@ data ModBreaks -- ^ 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? - , 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) [] } \end{code} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index f1ecd87..6d4b9de 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -64,7 +64,6 @@ import Panic import UniqFM import Maybes import ErrUtils -import Util import SrcLoc import BreakArray import RtClosureInspect @@ -83,7 +82,6 @@ import GHC.Exts import Data.Array import Exception import Control.Concurrent -import Data.List (sortBy) -- import Foreign.StablePtr import System.IO import System.IO.Unsafe @@ -139,16 +137,14 @@ data History = 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 - 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 @@ -163,7 +159,7 @@ getHistorySpan hsc_env hist = getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- hm_linkable hmi, [BCOs _ modBreaks] <- linkableUnlinked linkable = modBreaks | otherwise @@ -173,18 +169,13 @@ getModBreaks hmi -- 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. diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 03d0370..552b61c 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1963,11 +1963,11 @@ historyCmd arg _ -> 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) - (map (bold . ppr) names) + (map (bold . hcat . punctuate colon . map text) names) (map (parens . ppr) spans))) liftIO $ putStrLn $ if null rest then "" else "..." -- 1.7.10.4