diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 8b23e08003de6c13c61302de1205b71e7c99460a..12331e2d52b2544e8f17ea2593292b36f19741d6 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -432,8 +432,8 @@ schemeER_wrk d p rhs
return $ breakInstr `consOL` code
| otherwise = schemeE d 0 p rhs
-getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
-getVarOffSets dflags depth env = catMaybes . map getOffSet
+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
+getVarOffSets dflags depth env = map getOffSet
where
getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
index 628b576ca0fc26a6bfd6f813e1b535255ea43124..0c0c34ad64cb7b8a02e1bb5b30fc86a9f4a13303 100644
--- a/compiler/ghci/ByteCodeTypes.hs
+++ b/compiler/ghci/ByteCodeTypes.hs
@@ -35,6 +35,7 @@ import Data.Array.Base ( UArray(..) )
import Data.ByteString (ByteString)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
+import Data.Maybe (catMaybes)
import GHC.Exts.Heap
import GHC.Stack.CCS
@@ -110,14 +111,15 @@ instance NFData BCONPtr where
-- | Information about a breakpoint that we know at code-generation time
data CgBreakInfo
= CgBreakInfo
- { cgb_vars :: [(Id,Word16)]
+ { cgb_vars :: [Maybe (Id,Word16)]
, cgb_resty :: Type
}
+-- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs
-- Not a real NFData instance because we can't rnf Id or Type
seqCgBreakInfo :: CgBreakInfo -> ()
seqCgBreakInfo CgBreakInfo{..} =
- rnf (map snd cgb_vars) `seq`
+ rnf (map snd (catMaybes (cgb_vars))) `seq`
seqType cgb_resty
instance Outputable UnlinkedBCO where
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index b2c644e65c0632931a147a214f704472d3d10b20..ee43aaf6751cb92341836e2962a9606746860ab9 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -521,20 +521,17 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
breaks = getModBreaks hmi
info = expectJust "bindLocalsAtBreakpoint2" $
IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
- vars = cgb_vars info
+ mbVars = cgb_vars info
result_ty = cgb_resty info
occs = modBreaks_vars breaks ! breakInfo_number
span = modBreaks_locs breaks ! breakInfo_number
decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
- -- Filter out any unboxed ids;
+ -- Filter out any unboxed ids by changing them to Nothings;
-- we can't bind these at the prompt
- pointers = filter (\(id,_) -> isPointer id) vars
- isPointer id | [rep] <- typePrimRep (idType id)
- , isGcPtrRep rep = True
- | otherwise = False
+ mbPointers = nullUnboxed <$> mbVars
- (ids, offsets) = unzip pointers
+ (ids, offsets, occs') = syncOccs mbPointers occs
free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
@@ -550,11 +547,12 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time
let tv_subst = newTyVars us free_tvs
- filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
+ (filtered_ids, occs'') = unzip -- again, sync the occ-names
+ [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
(_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
map (substTy tv_subst . idType) filtered_ids
- new_ids <- zipWith3M mkNewId occs tidy_tys filtered_ids
+ new_ids <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
let result_id = Id.mkVanillaGlobal result_name
@@ -591,6 +589,24 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
| (tv, uniq) <- tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
+ isPointer id | [rep] <- typePrimRep (idType id)
+ , isGcPtrRep rep = True
+ | otherwise = False
+
+ -- Convert unboxed Id's to Nothings
+ nullUnboxed (Just (fv@(id, _)))
+ | isPointer id = Just fv
+ | otherwise = Nothing
+ nullUnboxed Nothing = Nothing
+
+ -- See Note [Syncing breakpoint info]
+ syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
+ syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs
+ where
+ joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
+ joinOccs = zipWith joinOcc
+ joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
+
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
let tmp_ids = [id | AnId id <- ic_tythings ic]
@@ -632,6 +648,35 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
ictxt0 = hsc_IC hsc_env
ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
+
+ {-
+ Note [Syncing breakpoint info]
+
+ To display the values of the free variables for a single breakpoint, the
+ function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint` pulls
+ out the information from the fields `modBreaks_breakInfo` and
+ `modBreaks_vars` of the `ModBreaks` data structure.
+ For a specific breakpoint this gives 2 lists of type `Id` (or `Var`)
+ and `OccName`.
+ They are used to create the Id's for the free variables and must be kept
+ in sync!
+
+ There are 3 situations where items are removed from the Id list
+ (or replaced with `Nothing`):
+ 1.) If function `compiler/ghci/ByteCodeGen.hs:schemeER_wrk` (which creates
+ the Id list) doesn't find an Id in the ByteCode environement.
+ 2.) If function `compiler/main/InteractiveEval.hs:bindLocalsAtBreakpoint`
+ filters out unboxed elements from the Id list, because GHCi cannot
+ yet handle them.
+ 3.) If the GHCi interpreter doesn't find the reference to a free variable
+ of our breakpoint. This also happens in the function
+ bindLocalsAtBreakpoint.
+
+ If an element is removed from the Id list, then the corresponding element
+ must also be removed from the Occ list. Otherwise GHCi will confuse
+ variable names as in #8487.
+ -}
+
-- -----------------------------------------------------------------------------
-- Abandoning a resume context
diff --git a/testsuite/tests/ghci.debugger/scripts/T8487.hs b/testsuite/tests/ghci.debugger/scripts/T8487.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d77738e3c97a352381850173d20edd7d0bd7589b
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T8487.hs
@@ -0,0 +1,11 @@
+import Control.Exception
+
+f = do
+ ma <- try $ evaluate a
+ x <- case ma of
+ Right str -> return a
+ Left err -> return $ show (err :: SomeException)
+ putStrLn x
+ where
+ a :: String
+ a = error "hi"
diff --git a/testsuite/tests/ghci.debugger/scripts/T8487.script b/testsuite/tests/ghci.debugger/scripts/T8487.script
new file mode 100644
index 0000000000000000000000000000000000000000..628088e954c77886ebfaa55a0f035f239e7d13b0
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T8487.script
@@ -0,0 +1,3 @@
+:l T8487.hs
+:b 5
+f
diff --git a/testsuite/tests/ghci.debugger/scripts/T8487.stdout b/testsuite/tests/ghci.debugger/scripts/T8487.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..ab7151a5636ac380885fbdebb7faf89aa810e512
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T8487.stdout
@@ -0,0 +1,4 @@
+Breakpoint 0 activated at T8487.hs:(5,8)-(7,53)
+Stopped in Main.f, T8487.hs:(5,8)-(7,53)
+_result :: IO String = _
+ma :: Either SomeException String = Left _
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index 8460fbb8093f2b5efeb03959dd7c949a6da53b0f..214222c8c3006b63d91a56a58f653a1157880b18 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -106,6 +106,7 @@ test('T2740', normal, ghci_script, ['T2740.script'])
test('getargs', extra_files(['../getargs.hs']), ghci_script, ['getargs.script'])
test('T7386', normal, ghci_script, ['T7386.script'])
+test('T8487', normal, ghci_script, ['T8487.script'])
test('T8557', normal, ghci_script, ['T8557.script'])
test('T12458', normal, ghci_script, ['T12458.script'])
test('T13825-debugger', when(arch('powerpc64'), expect_broken(14455)),