[Git][ghc/ghc][master] ghci: only keep the GlobalRdrEnv in ModInfo
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Mar 17 18:36:16 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
19d6d039 by sheaf at 2023-03-16T21:31:22+01:00
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 changed files:
- compiler/GHC.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
Changes:
=====================================
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.
=====================================
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
=====================================
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]
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19d6d0397c223bbec3c372d2b8c04c2e356c44a8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/19d6d0397c223bbec3c372d2b8c04c2e356c44a8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230317/7d4beb7e/attachment-0001.html>
More information about the ghc-commits
mailing list