ghci: only keep the GlobalRdrEnv in ModInfo

The datatype GHC.UI.Info.ModInfo used to store a ModuleInfo,
which includes a TypeEnv. This can easily cause space leaks as we
have no way of forcing everything in a type environment.

In GHC, we only use the GlobalRdrEnv, which we can force completely.
So we only store that instead of a fully-fledged ModuleInfo.

4 files changed, 49 insertions, 16 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 748a54fdef..a6cce31837 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1304,8 +1304,7 @@ compileCore simplify fn = do
           else
              return $ Right mod_guts
 
-     Nothing -> panic "compileToCoreModule: target FilePath not found in\
-                           module dependency graph"
+     Nothing -> panic "compileToCoreModule: target FilePath not found in module dependency graph"
   where -- two versions, based on whether we simplify (thus run tidyProgram,
         -- which returns a (CgGuts, ModDetails) pair, or not (in which case
         -- we just have a ModGuts.
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 58c446fb43..287b3d8788 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -2346,8 +2346,12 @@ typeAtCmd str = runExceptGhciMonad $ do
     (span',sample) <- exceptT $ parseSpanArg str
     infos      <- lift $ mod_infos <$> getGHCiState
     (info, ty) <- findType infos span' sample
-    lift $ printForUserModInfo (modinfoInfo info)
-                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])
+    let mb_rdr_env = case modinfoRdrEnv info of
+          Strict.Just rdrs -> Just rdrs
+          Strict.Nothing   -> Nothing
+    lift $ printForUserGlobalRdrEnv
+              mb_rdr_env
+              (sep [text sample,nest 2 (dcolon <+> ppr ty)])
 
 -----------------------------------------------------------------------------
 -- | @:uses@ command
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 39cf7d8860..0f78fa5075 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -42,6 +42,7 @@ import           GHC.Driver.Monad
 import           GHC.Driver.Env
 import           GHC.Driver.Ppr
 import           GHC.Types.Name
+import           GHC.Types.Name.Reader
 import           GHC.Types.Name.Set
 import           GHC.Utils.Outputable
 import           GHC.Types.SrcLoc
@@ -58,9 +59,8 @@ data ModInfo = ModInfo
       -- ^ Generated set of information about all spans in the
       -- module that correspond to some kind of identifier for
       -- which there will be type info and/or location info.
-    , modinfoInfo       :: !ModuleInfo
-      -- ^ Again, useful from GHC for accessing information
-      -- (exports, instances, scope) from a module.
+    , modinfoRdrEnv     :: !(Strict.Maybe GlobalRdrEnv)
+      -- ^ What's in scope in the module.
     , modinfoLastUpdate :: !UTCTime
       -- ^ The timestamp of the file used to generate this record.
     }
@@ -174,9 +174,9 @@ findName infos span0 mi string =
           UnhelpfulSpan {} -> tryExternalModuleResolution
           RealSrcSpan   {} -> return (getName name)
   where
+    rdrs = modInfo_rdrs mi
     tryExternalModuleResolution =
-      case find (matchName $ mkFastString string)
-                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
+      case find (matchName $ mkFastString string) rdrs of
         Nothing -> throwE "Couldn't resolve to any modules."
         Just imported -> resolveNameFromModule infos imported
 
@@ -198,8 +198,10 @@ resolveNameFromModule infos name = do
                             ppr modL)) return $
              M.lookup (moduleName modL) infos
 
+     let all_names = modInfo_rdrs info
+
      maybe (throwE "No matching export in any local modules.") return $
-         find (matchName name) (modInfoExports (modinfoInfo info))
+         find (matchName name) all_names
   where
     matchName :: Name -> Name -> Bool
     matchName x y = occNameFS (getOccName x) ==
@@ -311,9 +313,25 @@ getModInfo name = do
     p <- parseModule m
     typechecked <- typecheckModule p
     let allTypes = processAllTypeCheckedModule typechecked
-    let i = tm_checked_module_info typechecked
+        module_info = tm_checked_module_info typechecked
+        !rdr_env = case modInfoRdrEnv module_info of
+          Just rdrs -> Strict.Just rdrs
+          Nothing   -> Strict.Nothing
     ts <- liftIO $ getModificationTime $ srcFilePath m
-    return (ModInfo m allTypes i ts)
+    return $
+      ModInfo
+        { modinfoSummary    = m
+        , modinfoSpans      = allTypes
+        , modinfoRdrEnv     = rdr_env
+        , modinfoLastUpdate = ts
+        }
+
+-- | Get the 'Name's from the 'GlobalRdrEnv' of the 'ModInfo', if any.
+modInfo_rdrs :: ModInfo -> [Name]
+modInfo_rdrs mi =
+  case modinfoRdrEnv mi of
+    Strict.Nothing  -> []
+    Strict.Just env -> map greMangledName $ globalRdrEnvElts env
 
 -- | Get ALL source spans in the module.
 processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index fdd083c47b..3016dd66d5 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -24,7 +24,8 @@ module GHCi.UI.Monad (
         runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
         ActionStats(..), runAndPrintStats, runWithStats, printStats,
 
-        printForUserNeverQualify, printForUserModInfo,
+        printForUserNeverQualify,
+        printForUserModInfo, printForUserGlobalRdrEnv,
         printForUser, printForUserPartWay, prettyLocations,
 
         compileGHCiExpr,
@@ -41,6 +42,7 @@ import GHC.Driver.Monad hiding (liftIO)
 import GHC.Utils.Outputable
 import qualified GHC.Driver.Ppr as Ppr
 import GHC.Types.Name.Occurrence
+import GHC.Types.Name.Reader
 import GHC.Driver.Session
 import GHC.Data.FastString
 import GHC.Driver.Env
@@ -49,6 +51,7 @@ import GHC.Types.SafeHaskell
 import GHC.Driver.Make (ModIfaceCache(..))
 import GHC.Unit
 import GHC.Types.Name.Reader as RdrName (mkOrig)
+import qualified GHC.Types.Name.Ppr as Ppr (mkNamePprCtx )
 import GHC.Builtin.Names (gHC_GHCI_HELPERS)
 import GHC.Runtime.Interpreter
 import GHC.Runtime.Context
@@ -362,11 +365,20 @@ printForUserNeverQualify doc = do
   liftIO $ Ppr.printForUser dflags stdout neverQualify AllTheWay doc
 
 printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
-printForUserModInfo info doc = do
+printForUserModInfo info = printForUserGlobalRdrEnv (GHC.modInfoRdrEnv info)
+
+printForUserGlobalRdrEnv :: GhcMonad m => Maybe GlobalRdrEnv -> SDoc -> m ()
+printForUserGlobalRdrEnv mb_rdr_env doc = do
   dflags <- GHC.getInteractiveDynFlags
-  m_name_ppr_ctx <- GHC.mkNamePprCtxForModule info
-  name_ppr_ctx <- maybe GHC.getNamePprCtx return m_name_ppr_ctx
+  name_ppr_ctx  <- mkNamePprCtxFromGlobalRdrEnv dflags mb_rdr_env
   liftIO $ Ppr.printForUser dflags stdout name_ppr_ctx AllTheWay doc
+    where
+      mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
+      mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
+        withSession $ \ hsc_env ->
+        let unit_env = hsc_unit_env hsc_env
+            ptc = initPromotionTickContext dflags
+        in  return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
 
 printForUser :: GhcMonad m => SDoc -> m ()
 printForUser doc = do