Be more strict in CgBreakInfo to avoid GHCi leaking due to `Id`s retainingwip/break-leak

old environments on reload.

4 files changed, 75 insertions, 33 deletions

diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs
index 830b60a4ca..1b978c8953 100644
--- a/compiler/GHC/ByteCode/Types.hs
+++ b/compiler/GHC/ByteCode/Types.hs
@@ -15,6 +15,7 @@ module GHC.ByteCode.Types
   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
   , ItblEnv, ItblPtr(..)
   , CgBreakInfo(..)
+  , CgVar(..)
   , ModBreaks (..), BreakIndex, emptyModBreaks
   , CCostCentre
   ) where
@@ -23,6 +24,8 @@ import GHC.Prelude
 
 import GHC.Data.FastString
 import GHC.Data.SizedSeq
+import qualified GHC.Data.Strict as Strict
+import GHC.Iface.Type
 import GHC.Types.Id
 import GHC.Types.Name
 import GHC.Types.Name.Env
@@ -163,19 +166,33 @@ data BCONPtr
 instance NFData BCONPtr where
   rnf x = x `seq` ()
 
+data CgVar
+  = CgVar {
+    cgv_name :: !Name,
+    cgv_offset :: !Word16,
+    cgv_type :: !Type
+  }
+
+instance Outputable CgVar where
+  ppr CgVar{..} = text "CgVar"
+              <+> parens (ppr cgv_name
+                      <+> ppr cgv_offset
+                      <+> ppr cgv_type)
+
+instance NFData CgVar where
+  rnf CgVar{..} = rnf cgv_name `seq` rnf cgv_offset `seq` seqType cgv_type
+
 -- | Information about a breakpoint that we know at code-generation time
 data CgBreakInfo
    = CgBreakInfo
-   { cgb_vars   :: [Maybe (Id,Word16)]
-   , cgb_resty  :: Type
+   { cgb_vars   :: ![Strict.Maybe CgVar]
+   , cgb_resty  :: !Type
    }
 -- See Note [Syncing breakpoint info] in GHC.Runtime.Eval
 
--- Not a real NFData instance because we can't rnf Id or Type
-seqCgBreakInfo :: CgBreakInfo -> ()
-seqCgBreakInfo CgBreakInfo{..} =
-  rnf (map snd (catMaybes (cgb_vars))) `seq`
-  seqType cgb_resty
+instance NFData CgBreakInfo where
+  rnf CgBreakInfo{..} = rnf cgb_vars `seq` seqType cgb_resty
+
 
 instance Outputable UnlinkedBCO where
    ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
@@ -223,7 +240,7 @@ seqModBreaks ModBreaks{..} =
   rnf modBreaks_vars `seq`
   rnf modBreaks_decls `seq`
   rnf modBreaks_ccs `seq`
-  rnf (fmap seqCgBreakInfo modBreaks_breakInfo)
+  rnf modBreaks_breakInfo
 
 -- | Construct an empty ModBreaks
 emptyModBreaks :: ModBreaks
diff --git a/compiler/GHC/Data/Strict.hs b/compiler/GHC/Data/Strict.hs
index d028d51c64..c272f9cafa 100644
--- a/compiler/GHC/Data/Strict.hs
+++ b/compiler/GHC/Data/Strict.hs
@@ -9,6 +9,7 @@
 module GHC.Data.Strict (
     Maybe(Nothing, Just),
     fromMaybe,
+    catMaybes,
     Pair(And),
 
     -- Not used at the moment:
@@ -21,10 +22,20 @@ import GHC.Prelude hiding (Maybe(..), Either(..))
 import Control.Applicative
 import Data.Semigroup
 import Data.Data
+import Control.DeepSeq
+import GHC.Utils.Outputable (Outputable(..), text, (<+>))
 
 data Maybe a = Nothing | Just !a
   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
 
+instance NFData a => NFData (Maybe a) where
+  rnf Nothing = ()
+  rnf (Just x) = rnf x
+
+instance Outputable a => Outputable (Maybe a) where
+    ppr Nothing  = text "Nothing"
+    ppr (Just x) = text "Just" <+> ppr x
+
 fromMaybe :: a -> Maybe a -> a
 fromMaybe d Nothing = d
 fromMaybe _ (Just x) = x
@@ -37,6 +48,12 @@ altMaybe :: Maybe a -> Maybe a -> Maybe a
 altMaybe Nothing r = r
 altMaybe l _ = l
 
+catMaybes :: [Maybe a] -> [a]
+catMaybes = foldr go []
+  where
+    go Nothing xs = xs
+    go (Just x) xs = x : xs
+
 instance Semigroup a => Semigroup (Maybe a) where
   Nothing <> b       = b
   a       <> Nothing = a
@@ -56,6 +73,9 @@ instance Alternative Maybe where
 data Pair a b = !a `And` !b
   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
 
+instance (NFData a, NFData b) => NFData (Pair a b) where
+  rnf (And a b) = rnf a `seq` rnf b
+
 -- The definitions below are commented out because they are
 -- not used anywhere in the compiler, but are useful to showcase
 -- the intent behind this module (i.e. how it may evolve).
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 0b62544433..d437064591 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -45,6 +45,7 @@ module GHC.Runtime.Eval (
         ) where
 
 import GHC.Prelude
+import qualified GHC.Data.Strict as Strict
 
 import GHC.Driver.Monad
 import GHC.Driver.Main
@@ -120,7 +121,8 @@ import Data.Dynamic
 import Data.Either
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
-import Data.List (find,intercalate)
+import Data.List (find,intercalate, unzip4, zip4)
+import Data.Word
 import Control.Monad
 import Control.Monad.Catch as MC
 import Data.Array
@@ -571,9 +573,9 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
            -- we can't bind these at the prompt
        mbPointers = nullUnboxed <$> mbVars
 
-       (ids, offsets, occs') = syncOccs mbPointers occs
+       (local_names,types,offsets, occs') = syncOccs mbPointers occs
 
-       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)
+       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:types)
 
    -- It might be that getIdValFromApStack fails, because the AP_STACK
    -- has been accidentally evaluated, or something else has gone wrong.
@@ -587,12 +589,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, occs'') = unzip         -- again, sync the occ-names
-          [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
+       (filtered_names, filtered_types, occs'') = unzip3         -- again, sync the occ-names
+          [ (n, ty, occ) | (n, ty, Just _hv, occ) <- zip4 local_names types mb_hValues occs' ]
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
-                      map (substTy tv_subst . idType) filtered_ids
+                      map (substTy tv_subst) filtered_types
 
-   new_ids     <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
+   new_ids     <- zipWith3M mkNewId occs'' tidy_tys filtered_names
    result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
 
    let result_id = Id.mkVanillaGlobal result_name
@@ -615,10 +617,10 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
         -- state is single-threaded and otherwise we'd spam old bindings
         -- whenever we stop at a breakpoint.  The InteractveContext is properly
         -- saved/restored, but not the linker state.  See #1743, test break026.
-   mkNewId :: OccName -> Type -> Id -> IO Id
+   mkNewId :: OccName -> Type -> Name -> IO Id
    mkNewId occ ty old_id
      = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
-          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
+          ; return (Id.mkVanillaGlobal name ty) }
 
    newTyVars :: UniqSupply -> [TcTyVar] -> Subst
      -- Similarly, clone the type variables mentioned in the types
@@ -629,23 +631,24 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
      new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)
                                 (substTy subst (tyVarKind tv))
 
-   isPointer id | [rep] <- typePrimRep (idType id)
-                , isGcPtrRep rep                   = True
-                | otherwise                        = False
+   isPointer id = isPointerTy (idType id)
+   isPointerTy ty | [rep] <- typePrimRep ty
+                  , isGcPtrRep rep                   = True
+                  | otherwise                        = False
 
    -- Convert unboxed Id's to Nothings
-   nullUnboxed (Just (fv@(id, _)))
-     | isPointer id          = Just fv
-     | otherwise             = Nothing
-   nullUnboxed Nothing       = Nothing
+   nullUnboxed fv@(Strict.Just CgVar{..})
+     | isPointerTy cgv_type = fv
+     | otherwise            = Strict.Nothing
+   nullUnboxed Strict.Nothing       = Strict.Nothing
 
    -- See Note [Syncing breakpoint info]
-   syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
-   syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs
+   syncOccs :: [Strict.Maybe CgVar] -> [c] -> ([Name], [Type],[Word16], [c])
+   syncOccs mbVs ocs = unzip4 $ Strict.catMaybes $ joinOccs mbVs ocs
      where
-       joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
+       joinOccs :: [Strict.Maybe CgVar] -> [c] -> [Strict.Maybe (Name,Type,Word16,c)]
        joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc
-       joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
+       joinOcc mbV oc = (\CgVar{..} c -> (cgv_name,cgv_type,cgv_offset,c)) <$> mbV <*> pure oc
 
 rttiEnvironment :: HscEnv -> IO HscEnv
 rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 989121207d..51870939ee 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -14,6 +14,7 @@
 module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
 
 import GHC.Prelude
+import qualified GHC.Data.Strict as Strict
 
 import GHC.Driver.Session
 import GHC.Driver.Env
@@ -75,6 +76,7 @@ import Data.Char
 
 import GHC.Unit.Module
 
+import Control.DeepSeq
 import Data.Array
 import Data.Coerce (coerce)
 import Data.ByteString (ByteString)
@@ -384,11 +386,11 @@ schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
         return $ breakInstr `consOL` code
 schemeER_wrk d p rhs = schemeE d 0 p rhs
 
-getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
+getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Strict.Maybe CgVar]
 getVarOffSets platform depth env = map getOffSet
   where
     getOffSet id = case lookupBCEnv_maybe id env of
-        Nothing     -> Nothing
+        Nothing     -> Strict.Nothing
         Just offset ->
             -- michalt: I'm not entirely sure why we need the stack
             -- adjustment by 2 here. I initially thought that there's
@@ -399,7 +401,7 @@ getVarOffSets platform depth env = map getOffSet
             -- we trigger a breakpoint.
             let !var_depth_ws =
                     trunc16W $ bytesToWords platform (depth - offset) + 2
-            in Just (id, var_depth_ws)
+            in Strict.Just (CgVar (idName id) var_depth_ws (idType id))
 
 truncIntegral16 :: Integral a => a -> Word16
 truncIntegral16 w
@@ -2091,8 +2093,8 @@ getCCArray = BcM $ \st ->
 
 
 newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
-newBreakInfo ix info = BcM $ \st ->
-  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+newBreakInfo ix info = rnf info `seq` (BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()))
 
 getCurrentModule :: BcM Module
 getCurrentModule = BcM $ \st -> return (st, thisModule st)