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

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index d894523..ea41d98 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 "<end of history>" else "..."