[Git][ghc/ghc][wip/torsten.schmits/finder-boot] finder: Add `IsBootInterface` to finder cache keys
Sjoerd Visscher (@trac-sjoerd_visscher)
gitlab at gitlab.haskell.org
Thu Sep 12 14:22:59 UTC 2024
Sjoerd Visscher pushed to branch wip/torsten.schmits/finder-boot at Glasgow Haskell Compiler / GHC
Commits:
ba3dc458 by Torsten Schmits at 2024-09-12T16:22:45+02:00
finder: Add `IsBootInterface` to finder cache keys
- - - - -
12 changed files:
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Env.hs
- compiler/GHC/Unit/Types.hs
- + testsuite/tests/driver/boot-target/A.hs
- + testsuite/tests/driver/boot-target/A.hs-boot
- + testsuite/tests/driver/boot-target/B.hs
- + testsuite/tests/driver/boot-target/Makefile
- + testsuite/tests/driver/boot-target/all.T
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 mod_name location
+ mod <- liftIO $ addHomeModuleToFinder fc home_unit (notBoot mod_name) location
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
@@ -893,7 +893,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 modname location
+ addHomeModuleToFinder fc home_unit (GWIB modname (hscSourceToIsBoot hsc_src)) location
let ms = ModSummary {
ms_mod = this_mod,
ms_hsc_src = hsc_src,
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -2044,25 +2044,43 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
<- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
-
- -- Make a ModLocation for this file
- let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
+ src_path = unsafeEncodeUtf src_fn
+
+ is_boot = case takeExtension src_fn of
+ ".hs-boot" -> IsBoot
+ ".lhs-boot" -> IsBoot
+ _ -> NotBoot
+
+ (path_without_boot, hsc_src)
+ | isHaskellSigFilename src_fn = (src_path, HsigFile)
+ | IsBoot <- is_boot = (removeBootSuffix src_path, HsBootFile)
+ | otherwise = (src_path, HsSrcFile)
+
+ -- Make a ModLocation for the Finder, who only has one entry for
+ -- each @ModuleName@, and therefore needs to use the locations for
+ -- the non-boot files.
+ location_without_boot =
+ mkHomeModLocation fopts pi_mod_name path_without_boot
+
+ -- Make a ModLocation for this file, adding the @-boot@ suffix to
+ -- all paths if the original was a boot file.
+ location
+ | IsBoot <- is_boot
+ = addBootSuffixLocn location_without_boot
+ | otherwise
+ = location_without_boot
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
mod <- liftIO $ do
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
- addHomeModuleToFinder fc home_unit pi_mod_name location
+ addHomeModuleToFinder fc home_unit (GWIB pi_mod_name is_boot) location
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
, nms_src_hash = src_hash
- , nms_is_boot = NotBoot
- , nms_hsc_src =
- if isHaskellSigFilename src_fn
- then HsigFile
- else HsSrcFile
+ , nms_hsc_src = hsc_src
, nms_location = location
, nms_mod = mod
, nms_preimps = preimps
@@ -2090,9 +2108,10 @@ 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
+ 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 (ms_mod old_summary) location
+ HsSrcFile -> addModuleToFinder fc gwib location
_ -> return ()
hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
@@ -2230,7 +2249,6 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
, nms_src_hash = src_hash
- , nms_is_boot = is_boot
, nms_hsc_src = hsc_src
, nms_location = location
, nms_mod = mod
@@ -2243,7 +2261,6 @@ data MakeNewModSummary
= MakeNewModSummary
{ nms_src_fn :: FilePath
, nms_src_hash :: Fingerprint
- , nms_is_boot :: IsBootInterface
, nms_hsc_src :: HscSource
, nms_location :: ModLocation
, nms_mod :: Module
=====================================
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 mod_name location
+ addHomeModuleToFinder fc home_unit (GWIB mod_name (hscSourceToIsBoot src_flavour)) location
-- Make the ModSummary to hand to hscMain
let
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -89,23 +89,23 @@ type BaseName = OsPath -- Basename of file
initFinderCache :: IO FinderCache
initFinderCache = do
- mod_cache <- newIORef emptyInstalledModuleEnv
+ mod_cache <- newIORef emptyInstalledModuleWithIsBootEnv
file_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
- atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+ atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleWithIsBootEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
where
- is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
+ is_ext mod _ = not (isUnitEnvInstalledModule ue (gwib_mod mod))
- addToFinderCache :: InstalledModule -> InstalledFindResult -> IO ()
+ addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
addToFinderCache key val =
- atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleEnv c key val, ())
+ atomicModifyIORef' mod_cache $ \c -> (extendInstalledModuleWithIsBootEnv c key val, ())
- lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+ lookupFinderCache :: InstalledModuleWithIsBoot -> IO (Maybe InstalledFindResult)
lookupFinderCache key = do
c <- readIORef mod_cache
- return $! lookupInstalledModuleEnv c key
+ return $! lookupInstalledModuleWithIsBootEnv c key
lookupFileCache :: FilePath -> IO Fingerprint
lookupFileCache key = do
@@ -255,7 +255,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 mod do_this
+ modLocationCache fc (notBoot mod) do_this
findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
findExposedPackageModule fc fopts units mod_name mb_pkg =
@@ -312,7 +312,7 @@ findLookupResult fc fopts r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache :: FinderCache -> InstalledModuleWithIsBoot -> IO InstalledFindResult -> IO InstalledFindResult
modLocationCache fc mod do_this = do
m <- lookupFinderCache fc mod
case m of
@@ -322,17 +322,17 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
-addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()
+addModuleToFinder :: FinderCache -> ModuleWithIsBoot -> ModLocation -> IO ()
addModuleToFinder fc mod loc = do
- let imod = toUnitId <$> mod
- addToFinderCache fc imod (InstalledFound loc imod)
+ let imod = fmap toUnitId <$> mod
+ addToFinderCache fc imod (InstalledFound loc (gwib_mod imod))
-- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
+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 mod)
- return (mkHomeModule home_unit mod_name)
+ let mod = mkHomeInstalledModule home_unit <$> mod_name
+ addToFinderCache fc mod (InstalledFound loc (gwib_mod mod))
+ return (mkHomeModule home_unit (gwib_mod mod_name))
-- -----------------------------------------------------------------------------
-- The internal workers
@@ -466,7 +466,7 @@ 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 mod $
+ modLocationCache fc (notBoot mod) $
-- special case for GHC.Prim; we won't find it in the filesystem.
if mod `installedModuleEq` gHC_PRIM
=====================================
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 :: InstalledModule -> InstalledFindResult -> IO ()
+ , addToFinderCache :: InstalledModuleWithIsBoot -> InstalledFindResult -> IO ()
-- ^ Add a found location to the cache for the module.
- , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult)
+ , lookupFinderCache :: InstalledModuleWithIsBoot -> 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
=====================================
compiler/GHC/Unit/Module/Env.hs
=====================================
@@ -33,6 +33,17 @@ module GHC.Unit.Module.Env
, mergeInstalledModuleEnv
, plusInstalledModuleEnv
, installedModuleEnvElts
+
+ -- * InstalledModuleWithIsBootEnv
+ , InstalledModuleWithIsBootEnv
+ , emptyInstalledModuleWithIsBootEnv
+ , lookupInstalledModuleWithIsBootEnv
+ , extendInstalledModuleWithIsBootEnv
+ , filterInstalledModuleWithIsBootEnv
+ , delInstalledModuleWithIsBootEnv
+ , mergeInstalledModuleWithIsBootEnv
+ , plusInstalledModuleWithIsBootEnv
+ , installedModuleWithIsBootEnvElts
)
where
@@ -283,3 +294,56 @@ 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
=====================================
@@ -86,6 +86,8 @@ module GHC.Unit.Types
, GenWithIsBoot (..)
, ModuleNameWithIsBoot
, ModuleWithIsBoot
+ , InstalledModuleWithIsBoot
+ , notBoot
)
where
@@ -723,6 +725,8 @@ 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
@@ -736,3 +740,6 @@ 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}
=====================================
testsuite/tests/driver/boot-target/A.hs
=====================================
@@ -0,0 +1,5 @@
+module A where
+
+import B
+
+data A = A B
=====================================
testsuite/tests/driver/boot-target/A.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module A where
+
+data A
=====================================
testsuite/tests/driver/boot-target/B.hs
=====================================
@@ -0,0 +1,5 @@
+module B where
+
+import {-# source #-} A
+
+data B = B A
=====================================
testsuite/tests/driver/boot-target/Makefile
=====================================
@@ -0,0 +1,8 @@
+boot1:
+ $(TEST_HC) -c A.hs-boot B.hs
+
+boot2:
+ $(TEST_HC) A.hs-boot A.hs B.hs -v0
+
+boot3:
+ $(TEST_HC) A.hs-boot B.hs -v0
\ No newline at end of file
=====================================
testsuite/tests/driver/boot-target/all.T
=====================================
@@ -0,0 +1,10 @@
+def test_boot(name):
+ return test(name,
+ [extra_files(['A.hs', 'A.hs-boot', 'B.hs']),
+ ],
+ makefile_test,
+ [])
+
+test_boot('boot1')
+test_boot('boot2')
+test_boot('boot3')
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba3dc458e236795e5f22d9489af2861cef403edf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba3dc458e236795e5f22d9489af2861cef403edf
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/20240912/f84e8f75/attachment-0001.html>
More information about the ghc-commits
mailing list