[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
Fri Oct 4 15:04:04 UTC 2024
Sjoerd Visscher pushed to branch wip/sv/T25246-a at Glasgow Haskell Compiler / GHC
Commits:
780949a6 by Sjoerd Visscher at 2024-10-04T17:03:53+02:00
Don't store boot locations in finder cache
- - - - -
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
=====================================
@@ -2077,7 +2077,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
@@ -2110,10 +2110,9 @@ checkSummaryHash
-- 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)
+ let fc = hsc_FC hsc_env
case ms_hsc_src old_summary of
- HsSrcFile -> addModuleToFinder fc gwib location
+ HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location
_ -> return ()
hi_timestamp <- modificationTimeIfExists (ml_hi_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
@@ -89,23 +90,23 @@ type BaseName = OsPath -- Basename of file
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 -> (extendInstalledModuleWithIsBootEnv c key val, ())
+ atomicModifyIORef' mod_cache $ \c -> (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
@@ -255,7 +256,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 =
@@ -277,7 +278,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 = []
@@ -312,7 +313,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
@@ -322,17 +323,18 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
-addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()
addModuleToFinder fc mod loc = do
- let imod = fmap toUnitId <$> mod
- addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
+ let imod = toUnitId <$> mod
+ 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
@@ -342,7 +344,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,
@@ -367,7 +369,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,
@@ -437,7 +439,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.
@@ -466,11 +468,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
@@ -494,7 +496,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)]
@@ -528,7 +530,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/780949a6ec1ea5da777af99d70c177b134dd78c9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/780949a6ec1ea5da777af99d70c177b134dd78c9
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/20241004/493bd45b/attachment-0001.html>
More information about the ghc-commits
mailing list