diff options
author | sheaf <sam.derbyshire@gmail.com> | 2023-03-16 21:30:13 +0100 |
---|---|---|
committer | sheaf <sam.derbyshire@gmail.com> | 2023-03-16 21:31:22 +0100 |
commit | 19d6d0397c223bbec3c372d2b8c04c2e356c44a8 (patch) | |
tree | ce7f3eaaafb437323d8437876080ddad68518984 | |
parent | 6e3ce9a4ce2509ce779102ec6f8e8ddcb676f94b (diff) | |
download | haskell-19d6d0397c223bbec3c372d2b8c04c2e356c44a8.tar.gz |
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.
-rw-r--r-- | compiler/GHC.hs | 3 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 8 | ||||
-rw-r--r-- | ghc/GHCi/UI/Info.hs | 34 | ||||
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 20 |
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 |