[Git][ghc/ghc][wip/sv/T25246-a] Don't store boot locations in finder cache
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Mon Oct 7 14:46:39 UTC 2024
Sjoerd Visscher pushed to branch wip/sv/T25246-a at Glasgow Haskell Compiler / GHC
Commits:
786cbfb5 by Sjoerd Visscher at 2024-10-07T16:46:29+02:00
Don't store boot locations in finder cache
Partially reverts commit fff55592a7b
Amends add(Home)ModuleToFinder so that locations for boot files are not stored in the finder cache.
Removes InstalledModule field from InstalledFound constructor since it's the same as the key that was searched for.
- - - - -
8 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/GHC/Unit/Types.hs
Changes:
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -781,7 +781,7 @@ summariseRequirement pn mod_name = do
let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
let fc = hsc_FC hsc_env
- mod <- liftIO $ addHomeModuleToFinder fc home_unit (notBoot mod_name) location
+ mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
@@ -861,7 +861,6 @@ hsModuleToModSummary home_keys pn hsc_src modname
HsigFile -> os "hsig"
HsBootFile -> os "hs-boot"
HsSrcFile -> os "hs")
- -- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocnOut location0
_ -> location0
@@ -893,7 +892,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
this_mod <- liftIO $ do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB modname (hscSourceToIsBoot hsc_src)) location
+ addHomeModuleToFinder fc home_unit modname location hsc_src
let ms = ModSummary {
ms_mod = this_mod,
ms_hsc_src = hsc_src,
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2150,7 +2150,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
mod <- liftIO $ do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location
+ addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
@@ -2180,14 +2180,10 @@ checkSummaryHash
-- and it was likely flushed in depanal. This is not technically
-- needed when we're called from sumariseModule but it shouldn't
-- hurt.
- -- Also, only add to finder cache for non-boot modules as the finder cache
- -- makes sure to add a boot suffix for boot files.
- _ <- do
- let fc = hsc_FC hsc_env
- gwib = GWIB (ms_mod old_summary) (isBootSummary old_summary)
- case ms_hsc_src old_summary of
- HsSrcFile -> addModuleToFinder fc gwib location
- _ -> return ()
+ let fc = hsc_FC hsc_env
+ mod = ms_mod old_summary
+ hsc_src = ms_hsc_src old_summary
+ addModuleToFinder fc mod location hsc_src
hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -734,7 +734,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
mod <- do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
+ addHomeModuleToFinder fc home_unit mod_name location src_flavour
-- Make the ModSummary to hand to hscMain
let
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -897,7 +897,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
-- Look for the file
mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
case mb_found of
- InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
+ InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) -> do
-- See Note [Home module load error]
case mhome_unit of
Just home_unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -55,6 +55,7 @@ import GHC.Utils.Panic
import GHC.Linker.Types
import GHC.Types.PkgQual
+import GHC.Types.SourceFile
import GHC.Fingerprint
import Data.IORef
@@ -103,28 +104,28 @@ InstalledNotFound.
initFinderCache :: IO FinderCache
initFinderCache = do
- mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
+ mod_cache <- newIORef emptyInstalledModuleEnv
file_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
- atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
+ atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
where
- is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
- addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache key val =
atomicModifyIORef' mod_cache $ \c ->
- case (lookupInstalledModuleWithIsBootEnv c key, val) of
+ case (lookupInstalledModuleEnv c key, val) of
-- Don't overwrite an InstalledFound with an InstalledNotFound
-- See [Note Monotonic addToFinderCache]
(Just InstalledFound{}, InstalledNotFound{}) -> (c, ())
- _ -> (extendInstalledModuleWithIsBootEnv c key val, ())
+ _ -> (extendInstalledModuleEnv c key val, ())
- lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
lookupFinderCache key = do
c <- readIORef mod_cache
- return $! lookupInstalledModuleWithIsBootEnv c key
+ return $! lookupInstalledModuleEnv c key
lookupFileCache :: FilePath -> IO Fingerprint
lookupFileCache key = do
@@ -274,7 +275,7 @@ orIfNotFound this or_this = do
homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
- modLocationCache fc (notBoot mod) do_this
+ modLocationCache fc mod do_this
findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -296,7 +297,7 @@ findLookupResult fc fopts r = case r of
-- with just the location of the thing that was
-- instantiated; you probably also need all of the
-- implicit locations from the instances
- InstalledFound loc _ -> return (Found loc m)
+ InstalledFound loc -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
@@ -331,7 +332,7 @@ findLookupResult fc fopts r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache fc mod do_this = do
m <- lookupFinderCache fc mod
case m of
@@ -341,17 +342,19 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
-addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
-addModuleToFinder fc mod loc = do
- let imod = fmap toUnitId <$> mod
- addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO ()
+addModuleToFinder fc mod loc src_flavour = do
+ let imod = toUnitId <$> mod
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc imod (InstalledFound loc)
-- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleNameWithIsBoot -> ModLocation -> IO Module
-addHomeModuleToFinder fc home_unit mod_name loc = do
- let mod = mkHomeInstalledModule home_unit <$> mod_name
- addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))
- return (mkHomeModule home_unit (gwib_mod mod_name))
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module
+addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ unless (src_flavour == HsBootFile) $
+ addToFinderCache fc mod (InstalledFound loc)
+ return (mkHomeModule home_unit mod_name)
-- -----------------------------------------------------------------------------
-- The internal workers
@@ -361,7 +364,7 @@ findHomeModule fc fopts home_unit mod_name = do
let uid = homeUnitAsUnit home_unit
r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
+ InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -386,7 +389,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
let uid = RealUnit (Definite home_unit)
r <- findInstalledHomeModule fc fopts home_unit mod_name
return $ case r of
- InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+ InstalledFound loc -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
fr_paths = fmap unsafeDecodeUtf fps,
@@ -456,7 +459,7 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
-- This is important only when compiling the base package (where GHC.Prim
-- is a home module).
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
@@ -485,11 +488,11 @@ findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -
findPackageModule_ fc fopts mod pkg_conf = do
massertPpr (moduleUnit mod == unitId pkg_conf)
(ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
- modLocationCache fc (notBoot mod) $
+ modLocationCache fc mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ then return (InstalledFound (error "GHC.Prim ModLocation"))
else
let
@@ -513,7 +516,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- don't bother looking for it.
let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
- in return $ InstalledFound loc mod
+ in return $ InstalledFound loc
_otherwise ->
searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
@@ -547,7 +550,7 @@ searchPathExts paths mod exts = search to_search
search ((file, loc) : rest) = do
b <- doesFileExist file
if b
- then return $ InstalledFound loc mod
+ then return $ InstalledFound loc
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -30,9 +30,9 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
-- ^ remove all the home modules from the cache; package modules are
-- assumed to not move around during a session; also flush the file hash
-- cache.
- , addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
+ , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
-- ^ Add a found location to the cache for the module.
- , lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
+ , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
-- ^ Look for a location in the cache.
, lookupFileCache :: FilePath -> IO Fingerprint
-- ^ Look for the hash of a file in the cache. This should add it to the
@@ -40,7 +40,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
}
data InstalledFindResult
- = InstalledFound ModLocation InstalledModule
+ = InstalledFound ModLocation
| InstalledNoPackage UnitId
| InstalledNotFound [OsPath] (Maybe UnitId)
=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -33,17 +33,6 @@ module GHC.Unit.Module.Env
, mergeInstalledModuleEnv
, plusInstalledModuleEnv
, installedModuleEnvElts
-
- -- * InstalledModuleWithIsBootEnv
- , InstalledModuleWithIsBootEnv
- , emptyInstalledModuleWithIsBootEnv
- , lookupInstalledModuleWithIsBootEnv
- , extendInstalledModuleWithIsBootEnv
- , filterInstalledModuleWithIsBootEnv
- , delInstalledModuleWithIsBootEnv
- , mergeInstalledModuleWithIsBootEnv
- , plusInstalledModuleWithIsBootEnv
- , installedModuleWithIsBootEnvElts
)
where
@@ -294,56 +283,3 @@ plusInstalledModuleEnv :: (elt -> elt -> elt)
plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =
InstalledModuleEnv $ Map.unionWith f xm ym
-
-
---------------------------------------------------------------------
--- InstalledModuleWithIsBootEnv
---------------------------------------------------------------------
-
--- | A map keyed off of 'InstalledModuleWithIsBoot'
-newtype InstalledModuleWithIsBootEnv elt = InstalledModuleWithIsBootEnv (Map InstalledModuleWithIsBoot elt)
-
-instance Outputable elt => Outputable (InstalledModuleWithIsBootEnv elt) where
- ppr (InstalledModuleWithIsBootEnv env) = ppr env
-
-
-emptyInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a
-emptyInstalledModuleWithIsBootEnv = InstalledModuleWithIsBootEnv Map.empty
-
-lookupInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> Maybe a
-lookupInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = Map.lookup m e
-
-extendInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> a -> InstalledModuleWithIsBootEnv a
-extendInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m x = InstalledModuleWithIsBootEnv (Map.insert m x e)
-
-filterInstalledModuleWithIsBootEnv :: (InstalledModuleWithIsBoot -> a -> Bool) -> InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBootEnv a
-filterInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv e) =
- InstalledModuleWithIsBootEnv (Map.filterWithKey f e)
-
-delInstalledModuleWithIsBootEnv :: InstalledModuleWithIsBootEnv a -> InstalledModuleWithIsBoot -> InstalledModuleWithIsBootEnv a
-delInstalledModuleWithIsBootEnv (InstalledModuleWithIsBootEnv e) m = InstalledModuleWithIsBootEnv (Map.delete m e)
-
-installedModuleWithIsBootEnvElts :: InstalledModuleWithIsBootEnv a -> [(InstalledModuleWithIsBoot, a)]
-installedModuleWithIsBootEnvElts (InstalledModuleWithIsBootEnv e) = Map.assocs e
-
-mergeInstalledModuleWithIsBootEnv
- :: (elta -> eltb -> Maybe eltc)
- -> (InstalledModuleWithIsBootEnv elta -> InstalledModuleWithIsBootEnv eltc) -- map X
- -> (InstalledModuleWithIsBootEnv eltb -> InstalledModuleWithIsBootEnv eltc) -- map Y
- -> InstalledModuleWithIsBootEnv elta
- -> InstalledModuleWithIsBootEnv eltb
- -> InstalledModuleWithIsBootEnv eltc
-mergeInstalledModuleWithIsBootEnv f g h (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym)
- = InstalledModuleWithIsBootEnv $ Map.mergeWithKey
- (\_ x y -> (x `f` y))
- (coerce g)
- (coerce h)
- xm ym
-
-plusInstalledModuleWithIsBootEnv :: (elt -> elt -> elt)
- -> InstalledModuleWithIsBootEnv elt
- -> InstalledModuleWithIsBootEnv elt
- -> InstalledModuleWithIsBootEnv elt
-plusInstalledModuleWithIsBootEnv f (InstalledModuleWithIsBootEnv xm) (InstalledModuleWithIsBootEnv ym) =
- InstalledModuleWithIsBootEnv $ Map.unionWith f xm ym
-
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -84,8 +84,6 @@ module GHC.Unit.Types
, GenWithIsBoot (..)
, ModuleNameWithIsBoot
, ModuleWithIsBoot
- , InstalledModuleWithIsBoot
- , notBoot
)
where
@@ -720,8 +718,6 @@ type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
type ModuleWithIsBoot = GenWithIsBoot Module
-type InstalledModuleWithIsBoot = GenWithIsBoot InstalledModule
-
instance Binary a => Binary (GenWithIsBoot a) where
put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
put_ bh gwib_mod
@@ -735,6 +731,3 @@ instance Outputable a => Outputable (GenWithIsBoot a) where
ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
IsBoot -> [ text "{-# SOURCE #-}" ]
NotBoot -> []
-
-notBoot :: mod -> GenWithIsBoot mod
-notBoot gwib_mod = GWIB {gwib_mod, gwib_isBoot = NotBoot}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/786cbfb558d3d9aa2469a04035eabad4ea1b0f74
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/786cbfb558d3d9aa2469a04035eabad4ea1b0f74
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/20241007/84ccdfd3/attachment-0001.html>
More information about the ghc-commits
mailing list